VBA常用小代碼007：一鍵將總表數據拆分為多個分表

在工作中，有時我們需要快速將各個分表的數據合併成一張總表中，但有時我們又需要快速將總表的數據拆分成各個分表。

關於後者，可以使用以下代碼完成之。

代碼比較長，但操作過程和之前的系列小代碼是一樣的。複製到VBE新建模塊中運行即可。

操作動畫示例：

代碼參考如下：

Sub NewShts() Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x& Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd& Application.ScreenUpdating = False ""關閉屏幕更新 Application.DisplayAlerts = False ""關閉警告信息提示 Set d = CreateObject(""scripting.dictionary"") ""set字典 Set Rg = Application.InputBox(""請框選拆分依據列！只能選擇單列單元格區域！"", Title:=""提示"", Type:=8) ""用戶選擇的拆分依據列 tCol = Rg.Column ""取拆分依據列列標 tRow = Val(Application.InputBox(""請輸入總表標題行的行數？"")) ""用戶設置總表的標題行數 If tRow = 0 Then MsgBox ""你未輸入標題行行數，程序退出。"": Exit Sub Set Rng = ActiveSheet.UsedRange ""總表的數據區域 arr = Rng ""數據範圍裝入數組arr tCol = tCol - Rng.Column 1 ""計算依據列在數組中的位置 aCol = UBound(arr, 2) ""數據源的列數 For i = tRow 1 To UBound(arr) ""遍曆數組arr If Not d.exists(arr(i, tCol)) Then d(arr(i, tCol)) = i ""字典中不存在關鍵詞則將行號裝入字典 Else d(arr(i, tCol)) = d(arr(i, tCol)) & "","" & i ""如果存在則合併行號，以逗號間隔 End If Next For Each sht In Worksheets ""遍歷一遍工作表，如果字典中存在則刪除 If d.exists(sht.Name) Then sht.Delete Next kr = d.keys ""字典的key集 For i = 0 To UBound(kr) ""遍歷字典key值 If kr(i) <> """" Then ""如果key不為空 r = Split(d(kr(i)), "","") ""取出item里儲存的行號 ReDim brr(1 To UBound(r) 1, 1 To aCol) ""聲明放置結果的數組brr k = 0 For x = 0 To UBound(r) k = k 1 ""累加記錄行數 For j = 1 To aCol ""循環讀取列 brr(k, j) = arr(r(x), j) Next Next With Worksheets.Add(, Sheets(Sheets.Count)) ""新建一個工作表，位置在所有已存在sheet的後面 .Name = kr(i) ""表格命名 .[a1].Resize(tRow, aCol) = arr ""放標題行 .[a1].Offset(tRow, 0).Resize(k, aCol) = brr ""放置數據區域 Rng.Copy ""複製粘貼總表的格式 .[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False .[a1].Select End With End If Next Sheets(1).Activate ""激活第一個表格 Set d = Nothing ""釋放字典 Erase arr: Erase brr ""釋放數組 MsgBox ""數據拆分完成！"" Application.ScreenUpdating = True ""恢復屏幕更新 Application.DisplayAlerts = True ""恢復警示End Sub

小提示：?

如操作動畫所示，該段代碼允許用戶選擇工作表的整列，例如選擇表格的B列作為拆分依據列，不必擔心選取範圍過大造成程序運算卡死等情況。