好多人開始學習VBA，就是從工作簿、工作表的合并、拆分開始感興趣的。之前零零散散的寫過，還是整理成一個合集，留待備用。
單個excel文件是工作簿，excel文件中的Sheet是工作表。
▌一、合并工作簿
Sub 合并工作簿()
? ? Application.ScreenUpdating = False
? ? myfile = Dir(ThisWorkbook.Path & "\*.xls*")'Dir函數(shù)，獲取同路徑下待合并excel的文件名
? ? Do While myfile <> "" ?'當文件名不為空的時候，繼續(xù)運行，如果為空，說明表格已經(jīng)循環(huán)一個遍了
? ? ? ? ? ?If myfile <> ThisWorkbook.Name Then'在文件名不為空的前提下，還不能是代碼所在的匯總工作簿
? ? ? ? ? ? ? ? Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile)
? ? ? ? ? ? ? ? For m = 1 To wb.Worksheets.Count '對待匯總的工作簿中所有worksheet做循環(huán)
rrow = wb.Worksheets(m).UsedRange.Rows.Count
? ? ? ? ? ? ? ? wb.Worksheets(m).Range("a1:d" & rrow).Copy ThisWorkbook.Worksheets(1).Cells(Rows.Count, "a").End(xlUp).Offset(1, 0)
? ? ? ? ? ? ? ? Next
? ? ? ? ? ? ? ? Workbooks(myfile).Close False'復制完數(shù)據(jù)以后，分表關閉，不保存。
? ? ? ? ? ?Else
? ? ? ? ?End If
? ? ? ? myfile = Dir '獲取下一個待匯總工作簿的文件名
? ? Loop
? ? Application.ScreenUpdating = True
? ? MsgBox "完成"
End Sub
?綠色部分為按自己需要修改的代碼。文中代碼框架是匯總A：D列內(nèi)容。
這里著重說一下：代碼使用環(huán)境是待合并工作簿和代碼工作簿在同一個路徑下。
如果想彈出一個對話框，讓選擇路徑，再進行合并的話
只需要在上面的代碼中加如下代碼，并把"ThisWorkbook.Path"改為"PathSht"
Sub 合并工作簿() ? ?Application.ScreenUpdating = False ? ?With Application.FileDialog(msoFileDialogFolderPicker) '創(chuàng)建一個瀏覽文件夾的對話框 ? ? ? ?If .Show = -1 Then PathSht = .SelectedItems(1) Else Exit Sub ? ?End With
源代碼，省略不寫了,記得把"ThisWorkbook.Path"改為"PathSht"
....
End Sub
▌二、拆分工作簿
這段代碼可以實現(xiàn)對工作簿任意列的拆分。（對某一列相同內(nèi)容的所在行挑出來，匯總到一個新建工作簿里面）
Sub 拆分工作簿()
? ?Application.ScreenUpdating = False '關閉屏幕閃動，提速
? ?Application.DisplayAlerts = False '關閉窗口提示
? ?kk = 2
? ?Set dic = CreateObject("scripting.dictionary")
? ?With ThisWorkbook.Worksheets("待拆分的Sheet名")'根據(jù)自己的工作簿自行修改 ? ? ? ?cln = InputBox("請輸入需要按列拆分的列:" & Chr(10) & "英文列標", "輸入列標", "A") 'inputbox提示輸入需要拆分的列標
? ? ? ?cln2 = .Range("a1").End(xlToRight).Column '獲取最大列數(shù)，為了增加通用性
? ? ? ?If .Range(cln & 2) = "" Then Exit Sub
? ? ? ?rrow = .Cells(Rows.Count, cln).End(xlUp).Row
? ? ? ?arr = WorksheetFunction.Transpose(.Range(cln & 1 & ":" & cln & rrow))
? ? ? ?For i = 1 To UBound(arr) ?'將拆分條件列數(shù)據(jù)寫入字典，為了去重復。
? ? ? ? ? ?If Not dic.exists(arr(i)) Then '若字典中不存在該字符串，則寫入。
? ? ? ? ? ?dic.Add arr(i), .Range("a" & i).Resize(1, cln2)
? ? ? ?Else
? ? ? ? ? ?Set dic.Item(arr(i)) = Union(dic.Item(arr(i)), .Range("a" & i).Resize(1, cln2))
? ? ? ?End If
? ?Next
? ?k = dic.keys
? ?l = dic.items
? ?For ss = 0 To dic.Count - 1
? ? ? ?Set wb = Workbooks.Add '新建工作簿
? ? ? ?With wb.Worksheets(1)
? ? ? ? ? ?l(ss).Copy .Range("a1")
? ? ? ?End With
? ? ? ?wb.SaveAs ThisWorkbook.Path & "\" & k(ss) & ".xlsx" '將新建的工作簿保存在代碼工作簿下
? ? ? ?wb.Close True '關閉工作簿，并保存
? ? ? ?Set wb = Nothing '釋放內(nèi)存
? ?Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完成"
End Sub
上述代碼默認從第一行拆分，如果有標題行不想拆分，可以把上述下句代碼修改一下。
arr = WorksheetFunction.Transpose(.Range(cln &?1?& ":" & cln & rrow))，從哪一行開始拆分，就把1修改為行號
▌三、合并工作表（Sheet）
合并同一個工作簿下所有Sheet到一個Sheet里面就比較簡單了。
Sub 合并當前工作簿下的所有Sheet()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
? If Sheets(j).Name <> ActiveSheet.Name Then
? ? ? X = Range("A65536").End(xlUp).Row + 1
? ? ? Sheets(j).UsedRange.Copy Cells(X, 1)'默認復制所有內(nèi)容 ? End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "當前工作簿下的全部工作表已經(jīng)合并完畢！", vbInformation, "提示"
End Sub
默認復制所有內(nèi)容，如果有特定需要，自己修改綠色代碼部分。
▌四、拆分工作表（Sheet）
如下圖所示的拆分，也是很常見的問題。
Sub 拆分表格()
? ?Set d = CreateObject("scripting.dictionary")
? ?With Worksheets(1)
? ? ? ?rrow = .Cells(Rows.Count, "a").End(3).Row
? ? ? ?For i = 2 To rrow '從第2行開始拆分 ? ? ? ? ? ?strr = .Range("c" & i).Value '拆分C列內(nèi)容 ? ? ? ? ? ?If Not d.exists(strr) Then
? ? ? ? ? ? ? ?d.Add strr, .Range("a" & i).Resize(1, 4)
? ? ? ? ? ?Else
? ? ? ? ? ? ? ?Set d.Item(strr) = Union(d.Item(strr), .Range("a" & i).Resize(1, 4))
? ? ? ? ? ?End If
? ? ? ?Next
? ? ? ?k = d.keys
? ? ? ?i = d.items
? ? ? ?For a = 0 To d.Count - 1
? ? ? ? ? ?Worksheets.Add.Name = k(a)
? ? ? ? ? ?i(a).Copy Worksheets(k(a)).Range("a2")
? ? ? ?Next
? ?End With
End Sub
上述代碼用到了字典，具體用法，可以看我之前的文章《字典學習第一課（6方法4屬性）》
For i = 2 To rrow?'從第2行開始拆分??
strr = .Range("c" & i).Value?'拆分C列內(nèi)容
根據(jù)自己實際需求修改代碼即可。
= 好文推薦 =
