sql将一列拆分為多列_excel一鍵将總表資料拆分為多個分表

在工作中，有時我們需要快速将各個分表的資料合并成一張總表中，但有時我們又需要快速将總表的資料拆分成各個分表，可以使用以下代碼完成之。

代碼比較長，但操作過程和之前的系列小代碼是一樣的。複制到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列作為拆分依據列，不必擔心選取範圍過大造成程式運算卡死等情況。