[Excel VBA] 用 VBA 自動產生小計

Excel 本身提供小計的功能，可以讓資料依據某個欄位，做相關的小計，非常方便。

那如果，透過VBA該怎麼做呢?

首先，先準備一個底稿

透過ADO將資料擷取至Recordset中，將資料依據底稿的順序排列好，利用

Range("A2").CopyFromRecordset rs

將資料放到 A2 這個 Cell 展開

再透過 Subtotal

Range("A1:V29").Select

Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22)

將資料依據第一個欄位 (GroupBy:=1)，做小計 (xlSum)，並決定要小計的欄位 (利用 Array() 將小計的欄位置入 TotalList)

大功告成！

顏色的部分可以透過

Cells(iRow, 3).Interior.Color = RGB(218, 238, 243)

來達成

Read more

[Excel VBA] 用 VBA 控制 Group Column 收合/展開

最近有個需求，是要將 Excel 群組的欄位，在打開檔案時，依時間自動展開該季的欄位，並將其他季的欄位位縮合

網路上查到的，多半是用 Outline.ShowLevels

但這個主要是當有群組階層時，可以針對哪一個階層設定展開或收合，並不是我要用的

就寫一個Sub Routine，依季的時間，傳入 Range Column 將該區間的欄位收合或展開

Public Sub GroupColumnCollapse(oSheet As Worksheet, s As String, e As String, collapse As Boolean)
  If oSheet.Range(s & "1:" & e & "1").EntireColumn.Hidden Then 
    oSheet.Range(s & "1:" & e & "1").EntireColumn.Hidden = collapse
  End If
End Sub

用到的是 Range EntireColumn.Hidden 這個屬性來控制

Read more

[Excel VBA] 消失的快捷鍵，用VBA補回來！

因為工作的需要，常常幫公司同仁撰寫 Excel 巨集程式，方便他們處理資料

也為了簡化操作，所以設定快捷鍵讓他們可以一鍵執行巨集（例如：Ctrl+u）
（註：原 Ctrl+u 鍵是幫文字加底線）

在 Excel 2003 的時候，只要將巨集安全性設為中，告訴使用者打開 Excel 檔時，啟用巨集
這樣執行起來都沒什麼問題

但到了 Excel 2007 & 2010 的版本，對於 Excel 巨集的控制嚴格了，很多原來可以使用的功能，通通不行了。即使信任文件，告訴使用者要啟用內容，快捷鍵還是常常會不見了！

試了很久，找不出問題，有的人的電腦可以，但有的人的不行，總不能一個一個去幫他們調吧！所以乾脆，在程式中強制按鍵的設定

1. Private Sub Workbook_Open()  
2.   
3.   Application.OnKey "^u", "doUpdate"  
4.   Application.OnKey "^r", "doRefresh"    
5.   
6. End Sub  

這樣就不用傷腦筋了！

Read more

[Excel VBA]關掉 Excel Menu Bar 的方法

Excel 是一個相當好用的工具，提供了相當多的內建函數與巨集可以讓我們做出相當漂亮與豐富的報表。

但對於習慣寫程式或者是需要使用 Excel 來當作程式主體的人來說，這些 Menu Bar 可以說是擾亂程式的元兇。

所以本篇就要介紹，如何關掉 Excel 的 Menu Bar，讓 Excel 看起來乾乾淨淨。

其實只有一個指令，

檢視原始檔複製到剪貼簿列印關於

1. Application.CommandBars("Worksheet Menu Bar").Enabled=False

這個指令是將主 Menu 關掉的意思，其他的像 ToolBar 等都還會存在。

如果您只想要關掉某些功能呢?

首先您要知道那些功能的名稱是什麼，怎麼知道呢? Google? 可能找到的都是片段，可以透過一段程式將所有的 Menu Bar 名稱 Show 出來，如下面這一小段程式碼

檢視原始檔複製到剪貼簿列印關於

1. Dim oBar as CommandBar
3. For Each oBar in Application.CommandBars
4.   Debug.Print oBar.Name
5. Next

這樣就可以知道有哪些 Menu Bar 存在於 Excel 中，所以將這些名稱透過 Application.CommandBars 的指令，一一把它關掉即可。

您必須在一開啟 Workbook 時就去下這一段的指令(在 ThisWorkBook當中)，如:

檢視原始檔複製到剪貼簿列印關於

1. Private Sub Workbook_Open()
2.   Application.CommandBars("Worksheet Menu Bar").Enabled=False
3. End Sub

將上述的動作寫成了一個 VB Module，提供開關的方式供網友參考。有些功能表的名稱需要對照(或Google)一下，或是測試一下關掉的是哪一個部份。也歡迎網友修正後再分享出來。

原始碼：mdlMenu.bas

Read more

尾牙賓果券程式

又是年終尾牙歡樂的時刻
今年公司福委會決定恢復往年玩賓果的遊戲
於是找上我寫一個產生賓果券的程式

用什麼寫呢? 當然是 Excel 囉 直接利用它的 CELL 當作賓果券的格子再適當也不過

公司這次希望每一個人有六個賓果遊戲券，每一個賓果券有 7 X 7  49 個號碼
以亂數產生，抽獎球1~88號

依照此需求我們先在 Excel VBA 中定義所需常數

Const maxball = 88 ' 最大號碼 Const matrix = 7     ' 方型矩陣UBound Const Nbr = 6         ' 幾個方型矩陣 Const rs = 3            ' 第一個方形矩陣開始 Cell 的 Row Const rc = 2            ' 第一個方形矩陣開始 Cell 的 Column Dim bingo(Nbr, matrix, matrix) As Integer ' 存放 BINGO 券號碼的三維陣列

有此定義後，開始撰寫主程式

iCount = 2 ' 主頁資料開始列   Do While Data.Cells(iCount, 1) <> "" ' 如果主頁資料為空白就停止讀取        sheetcount = sheetcount + 1  ' 為每一個資料列產生新的工作表       Worksheets("Template").Copy after:=Worksheets(sheetcount)   ' 透過 Template 產生新工作表       Set NewSheet = Sheets(sheetcount + 1)       NewSheet.Name = Data.Cells(iCount, 2)       NewSheet.Visible = True       NewSheet.Activate       NewSheet.Cells(2, 2) = "工號：" & Data.Cells(iCount, 1) & " 姓名：" & Data.Cells(iCount, 2)        Randomize    ' 對亂數產生器做初始化的動作。       For i = 1 To Nbr         DoEvents         For j = 1 To matrix           DoEvents           For k = 1 To matrix             DoEvents Continue:            seed = Int((maxball * Rnd) + 1)    ' 產生 1 到 maxball 之間的亂數值。             If Not CheckSeed(seed, i) Then  ' 檢查此亂數是否已出現過               GoTo Continue             End If             bingo(i, j, k) = seed   ' 將亂數值存到陣列中           Next k         Next j       Next i       For i = 1 To Nbr  ' 全部產生完畢後，將結果輸出         DoEvents         For j = 1 To matrix           DoEvents           For k = 1 To matrix             DoEvents             Select Case i               Case 1                 iRow = rs: iCol = rc               Case 2                 iRow = rs: iCol = rc + matrix + 1               Case 3                 iRow = rs + matrix + 1: iCol = rc               Case 4                 iRow = rs + matrix + 1: iCol = rc + matrix + 1               Case 5                 iRow = rs + 2 * matrix + 2: iCol = rc               Case 6                 iRow = rs + 2 * matrix + 2: iCol = rc + matrix + 1             End Select             NewSheet.Cells(iRow + (j - 1), iCol + (k - 1)) = bingo(i, j, k)           Next k         Next j       Next i       ResetBinGo       iCount = iCount + 1   Loop

引用Function

Private Sub ResetBinGo()   Dim i As Integer, j As Integer, k As Integer   For i = 1 To Nbr     For j = 1 To matrix       For k = 1 To matrix         bingo(i, j, k) = 0       Next k     Next j   Next i End Sub Private Function CheckSeed(n As Integer, i As Integer) As Boolean   Dim j As Integer, k As Integer   CheckSeed = True   For j = 1 To matrix     DoEvents     For k = 1 To matrix       DoEvents       If n = bingo(i, j, k) Then         CheckSeed = False       End If     Next k   Next j End Function

執行時，請記得將VBA安全性調到中度安全性，並且要啟用巨集

按產生賓果券，開始執行

大功告成，不過因為是一個Sheet一個Sheet產生，可能要注意Excel記憶體的問題(還沒正式測啦)

 

Read more