一、合併工作簿 Sub 合併工作簿() Application.ScreenUpdating = False myfile = Dir(ThisWorkbook.Path & "\*.xls*")'Dir函式，獲取同路徑下待合併excel的檔名 Do While myfile <> ""'當檔名不為空的時候，繼續執行，如果為空，說明表格已經迴圈一個遍了 If myfile <> ThisWorkbook.Name Then'在檔名不為空的前提下，還不能是程式碼所在的彙總工作簿 Set wb = Workbooks.Open(ThisWorkbook.Path & "" & myfile) For m = 1 To wb.Worksheets.Count '對待彙總的工作簿中所有worksheet做迴圈 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'複製完資料以後，分表關閉，不儲存。 Else End If myfile = Dir '獲取下一個待彙總工作簿的檔名 Loop Application.ScreenUpdating = True MsgBox "完成" End Sub 綠色部分為按自己需要修改的程式碼。文中程式碼框架是彙總A：D列內容。 這裡著重說一下：程式碼使用環境是待合併工作簿和程式碼工作簿在同一個路徑下。 Sub 合併工作簿() Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) '建立一個瀏覽資料夾的對話方塊 If .Show = -1 Then PathSht = .SelectedItems(1) Else Exit Sub End With 原始碼，省略不寫了,記得把"ThisWorkbook.Path"改為"PathSht" .... End Sub 二、拆分工作簿 這段程式碼可以實現對工作簿任意列的拆分。（對某一列相同內容的所在行挑出來，彙總到一個新建工作簿裡面） Sub 拆分工作簿() Application.ScreenUpdating = False '關閉螢幕閃動，提速 Application.DisplayAlerts = False '關閉視窗提示 kk = 2 Set dic = CreateObject("scripting.dictionary") With ThisWorkbook.Worksheets("待拆分的Sheet名")'根據自己的工作簿自行修改 cln = InputBox("請輸入需要按列拆分的列:" & Chr(10) & "英文列標", "輸入列標", "A") 'inputbox提示輸入需要拆分的列標 cln2 = .Range("a1").End(xlToRight).Column '獲取最大列數，為了增加通用性 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)'將拆分條件列資料寫入字典，為了去重複。 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 '釋放記憶體 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)'預設複製所有內容 End If Next Range("B1").Select Application.ScreenUpdating = True MsgBox "當前工作簿下的全部工作表已經合併完畢！", vbInformation, "提示" End Sub 預設複製所有內容，如果有特定需要，自己修改這部分程式碼Sheets(j).UsedRange.Copy Cells(X, 1)'預設複製所有內容。 四、拆分工作表（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列內容 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 上述程式碼用到了字典 For i = 2 To rrow '從第2行開始拆分 strr = .Range("c" & i).Value '拆分C列內容 根據自己實際需求修改程式碼即可。