如何快速的合併多個 Excel 工作簿成為一個工作簿？

01-19

晚上試了一下，樓主的方法可行，謝謝。
補充一點，如果是 2007版本，把代碼中的 xls 修改為 xlsx就可以了。

2016-05-15更新：如果是excel2007及更新的版本，則需要把代碼中的xls修改為xlsx即可，祝大家成功！

------------------------------------------------------------------------------------------------------------------------

沒人給直接答案，那我自問自答了。

的確去百度了下，出現了很多種方法，但是，目前就這個方法行得通，跟大家分享下：

用一個VBA就可以實現的。

使用方法：

1、新建一個工作薄，將其命名為你合併後的名字。

2、打開此工作薄。

3、在其下任一個工作表標籤上點擊右鍵，選擇「查看代碼」。

4、在打開的VBA編輯窗口中粘貼以下代碼：

Sub 工作薄間工作表合併()

Dim FileOpen

Dim X As Integer

Application.ScreenUpdating = False

FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合併工作薄")

X = 1

While X &<= UBound(FileOpen)

Workbooks.Open Filename:=FileOpen(X)

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

X = X + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

errhadler:

MsgBox Err.Description

End Sub

5、關閉VBA編輯窗口。

6、在excel中，工具---宏---宏,選「工作薄間工作表合併」,然後「執行」。

7、在打開的對話窗口中，選擇你要合併的300個工作薄。

8、等待。。。。ok！

來源：http://zhidao.baidu.com/question/125523677.html

最高票回答是把多個工作簿合併成一個工作簿中的多個sheet，看到有朋友需要進一步合併成一個sheet中的多行。現補充分享如下：

使用方法：

1、在包含多個sheet的工作簿中（如多個工作簿合併後含n個sheet的工作簿），新建一個sheet

2、在新建的sheet標籤上點擊右鍵，選擇「查看代碼」

3、在打開的VBA編輯窗口中粘貼以下代碼：

Sub 合併當前工作簿下的所有工作表()

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

運行即可。

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m

Set sh = ActiveSheet

MyPath = ThisWorkbook.Path ""

MyName = Dir(MyPath "*.xls")

Application.ScreenUpdating = False

Cells.ClearContents

Do While MyName &<&> ""

If MyName &<&> ThisWorkbook.Name Then

With GetObject(MyPath MyName)

For Each sht In .Sheets

If IsSheetEmpty = IsEmpty(sht.UsedRange) Then

m = m + 1

If m = 1 Then

sht.[a1].CurrentRegion.Copy sh.[a1]

Else

sht.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1)

End If

.Close False

End With

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

End Sub

這個問題我給你推薦使用Excel裡邊的PowerQuery去解決這個問題，因為2016版excel已經完全把Powerquery的功能加入到數據標籤里。想了解的話可以看看我之前在專欄整理的一篇簡單實操方法https://zhuanlan.zhihu.com/p/26164792

試了一下 @葉玄楓的答案，可以將多個獨立的excel文件合併到一個excel工作表中。但有個問題：合併後的工作表中有數據丟失。即從第二個開始到最後一個，會丟失原始Excel文件中的第一行數據。

其VBA代碼如下：

作者：葉玄楓
Sub Macro1() Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m Set sh = ActiveSheet MyPath = ThisWorkbook.Path "" MyName = Dir(MyPath "*.xls") Application.ScreenUpdating = False Cells.ClearContents Do While MyName &<&> "" If MyName &<&> ThisWorkbook.Name Then With GetObject(MyPath MyName) For Each sht In .Sheets If IsSheetEmpty = IsEmpty(sht.UsedRange) Then m = m + 1 If m = 1 Then sht.[a1].CurrentRegion.Copy sh.[a1] Else sht.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1) End If End If Next .Close False End With End If MyName = Dir Loop Application.ScreenUpdating = True End Sub

應該是

sht.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1)

中的CurrentRegion.Offset(1) 將數據選擇區域減小了，因此將上面的代碼改為

sht.[a1].CurrentRegion.Copy sh.[a65536].End(xlUp).Offset(1)

可以解決這個問題。

另外將

MyName = Dir(MyPath "*.xls")

中的*.xls修改為*.xlsx和*.csv可分別合併07版本以後的Excel文件和csv文件

使用Free download Kutools for Excel

安裝後，在「企業」-&>「匯總"里，就可以解決你的問題。

這是一個增加工具。

另外我想說的是，搜索的使用，用谷歌+英語關鍵詞來搜索。

使用百度，你總是很難找到答案的。

以上都是VBA的方法，雖然可以完成功能，但不夠完善，而且速度太慢。

多薄多表合併mergebooks.dll中使用的不是以上方法，速度快多了。

之前寫過一個真實的案例，可以參考下，這是最複雜的情況之一，請看下面介紹：

-----------------------------------------------------------------------

1、

一個文件夾下有很多個工作簿。

2、

每個工作簿裡面有3個sheet表，結構一樣。

-----------------------------------------------------------------------

3、

要求如上，根據名稱、代號、長度三個條件，匯總數量。這是多工作簿，多工作表，多條件匯總。具有代表性。

-----------------------------------------------------------------------

代碼如下：

Option Explicit Sub 匯總2() Dim i%, j%, f$, k%, n%, m% Dim wb As Workbook, sht As Worksheet Dim d As Object, s Dim arr, arr1() Set d = CreateObject("scripting.dictionary")


      s = Timer

      f = Dir(ThisWorkbook.Path  "*test*.xlsx")

      Application.ScreenUpdating = False

      Application.DisplayAlerts = False

      Do While f &<&> ""

               Set wb = Workbooks.Open(ThisWorkbook.Path  ""  f)

               For Each sht In Worksheets

                         sht.Activate

                         i = [a100000].End(3).Row
                         arr = Range("A3:D"  i)

                         For k = 1 To UBound(arr)

                         If Not d.exists(arr(k, 1)  arr(k, 2)  arr(k, 3)) Then

                              n = n + 1

                              d(arr(k, 1)  arr(k, 2)  arr(k, 3)) = n

                              ReDim Preserve arr1(1 To 4, 1 To n) "必須重新定義數組的維度

                              arr1(1, n) = arr(k, 1)

                              arr1(2, n) = arr(k, 2)

                              arr1(3, n) = arr(k, 3)

                              arr1(4, n) = arr(k, 4)

                         Else

                              m = d(arr(k, 1)  arr(k, 2)  arr(k, 3))

                              arr1(4, m) = arr1(4, m) + arr(k, 4)

                         End If

                         Next k

                         Erase arr
               Next sht

               wb.Close False

     f = Dir

     Loop

              Range("A2").Resize(d.Count, 4) = Application.Transpose(arr1)

              Range("A1:D1") = Array("名稱", "代號", "長度", "數量")
              ActiveWorkbook.Worksheets("匯總2-字典").Sort.SortFields.Clear

              ActiveWorkbook.Worksheets("匯總2-字典").Sort.SortFields.Add Key:=Range("A8"), _

              SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

              With ActiveWorkbook.Worksheets("匯總2-字典").Sort

                  .SetRange Range("A2:D10")

                  .Header = xlNo

                  .MatchCase = False

                  .Orientation = xlTopToBottom

                  .SortMethod = xlPinYin

                  .Apply

               End With

              MsgBox "匯總報表用時"  s - Timer  "秒"

End Sub

我用了120個工作簿做了測試，運行時間為69.58594秒！這效率有多高？

補充幾點注意事項：

1.要在工作簿所在文件里新建一個工作簿，把這段代碼放到VBE編輯器中，並存為.xlsm格式。

2.f = Dir(ThisWorkbook.Path "*test*.xlsx")

這句代碼是用來識別你文件夾下文件名稱的，其實中間的test沒有必要寫，我這是看每個文件的文件名都有test，才這樣寫的。寫成：f = Dir(ThisWorkbook.Path "*.xlsx") 就行。

我搜索到這個問題是因為想把20多個csv文件合併成一個，google到一個非常簡單的辦法http://www.solveyourtech.com/merge-csv-files/

不知道切不切題。

VBA 啥的太複雜發個小白用的，，，

下載插件也不錯，，，不過是VBA集合。。

如果你用的是Office2016的話，其自帶的Power Query就能完美解決，

但若是Office2007~2013版的話，就需要去微軟官方網站下載了

（下載地址：用於 Excel 的 Microsoft Power Query）。

用它最簡單的完成合併工作。

從Excel數據項目中，點擊「新建查詢-從文件-從工作簿」後選取需要製作的表格後，在「導航器選取需要合併的多個工作表，點擊「編輯」。

在彈出的界面中選擇「追加查詢」，選取需要合併的表格，添加到右側展示框中。

最後點擊「關閉並上載」就完成了本次數據的合併工作，非常簡單吧。

當然，如果咱們僅是為了查詢工作簿中的某些數據，也可以不進行合併操作，直接在「查找和選項」中選擇搜索範圍為整個工作簿，而不是單個工作表。

兩個需求兩種解決辦法，最簡單的工作簿合併和數據查詢操作，

今天剛好要用到搜了一下，可以實現，方法也很簡單：

將要合併的excel工作簿放在一個文件夾，在文件夾內新建一個excel，命名後保存。在新建excel內 ALT+F11 ,雙擊左方工程資源管理器裡面的sheet1(sheet1),在代碼區粘貼如下代碼。運行。

代碼為：

sub 合併當前目錄下所有工作簿的全部工作表()

dim mypath, myname, awbname

dim wb as workbook, wbn as string

dim g as long

dim num as long

dim box as string

application.screenupdating = false

mypath = activeworkbook.path

myname = dir(mypath "" "*.xls")

awbname = activeworkbook.name

num = 0

do while myname &<&> ""

if myname &<&> awbname then

set wb = workbooks.open(mypath "" myname)

num = num + 1

with workbooks(1).activesheet

.cells(.range("a65536").end(xlup).row + 2, 1) = left(myname, len(myname) - 4)

for g = 1 to sheets.count

wb.sheets(g).usedrange.copy .cells(.range("a65536").end(xlup).row + 1, 1)

wbn = wbn chr(13) wb.name

wb.close false

end with

end if

myname = dir

loop

range("a1").select

application.screenupdating = true

msgbox "共合併了" num "個工作薄下的全部工作表。如下：" chr(13) wbn, vbinformation, "提示"

end sub

多個文件中的工作表原樣複製到一個文件中的多個表

------------------------------------------

Sub CombineFiles()

Dim path As String

Dim FileName As String

Dim LastCell As Range

Dim Wkb As Workbook

Dim WS As Worksheet

Dim ThisWB As String

Dim MyDir As String

MyDir = ThisWorkbook.path ""

"ChDriveLeft(MyDir, 1) "find all the excel files

"ChDir MyDir

"Match =Dir$("")

ThisWB = ThisWorkbook.Name

Application.EnableEvents = False

Application.ScreenUpdating = False

path = MyDir

FileName = Dir(path "*.xlsx", vbNormal)

Do Until FileName = ""

If FileName &<&> ThisWB Then

Set Wkb = Workbooks.Open(FileName:=path "" FileName)

For Each WS In Wkb.Worksheets

Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)

If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then

Else

WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

End If

Next WS

Wkb.Close False

End If

FileName = Dir()

Loop

Application.EnableEvents = True

Application.ScreenUpdating = True

Set Wkb = Nothing

Set LastCell = Nothing

End Sub

我就湊個熱鬧……

MAC自帶的Automator有現成的合併多張sheet並生成新文件的功能，多做幾個步驟還能順手轉換成PDF

合併工作薄,合併工作表

多薄多表合併——excel 外接程序插件

使用說明

幾百個工作薄、幾千個工作表，要匯總？怎麼辦？複製、粘貼……？搞死人，而且易出錯！多薄多表合併，一鍵幫你搞定！ ——mergebooks.dll

下載地址：請輸入提取碼訪問密碼 46d7

一、功能：

1、多薄合併：將某一文件夾或當前文件夾下所有工作薄合併到一個自動新建的「匯總表」工作薄中。每個工作薄中可含多個不同的工作表，工作表與工作表一一對應（合併）。

默認合併當前文件夾下的所有工作薄；在啟動excel後（未保存）的新工作薄中點擊該按鈕則打開「文件夾選擇」對話框。

2、多表合併：將當前工作薄中所有工作表合併到一個自動生成且位於最後的「匯總表」工作表中。

3、清除數據：清除當前工作表或當前工作薄中所有工作表數據。默認「取消」按鈕（即按Enter後）僅清除當前工作表中的數據。

4、分類匯總：根據所選區域第一列中各行對其後各列數據進行匯總（求和）。分類匯總後將匯總結果放置到所選擇的目標區域，匯總結果的第一列中各行不存在重複數據，即第一列「去除重複行」，其後各列數據求和或文本聯接。

5、拆分表格：根據所選區域第一列中各行內容拆分為許多工作表，以第一列中各行內容為工作表名稱，並複製其後面的各列內容。

6、選擇查詢：根據所選區域第一列中各行內容和所選單元格中的內容進行查找，並將查詢結果（符合查詢條件的許多行）放置到所選擇的目標區域。

二、注意：

多薄合併、多表合併：要合併的工作薄（或工作表）格式必須一致；工作表一一對應；所有工作表的表頭行數必須相同；僅複製表頭以下的行；多薄多表合併，具有「去除重複行」功能，即一行中所有數據均相同的行僅保留一行；工作表下方不要有備註行。

三、安裝使用：

1、安裝時可能受360警告或攔截，這是正常提示，選擇「添加信任」或「直接運行」即可。

安裝完成後，在excel2003工具欄、excel2010「載入項」中會出現——「多薄合併、多表合併、清除數據、分類匯總、拆分表格、選擇查詢」等功能按鈕。

2、默認安裝位置為C:WINDOWSmergebooks.dll ; 如果電腦進行了多用戶設置，如電腦用戶為lcb,可把mergebooks.dll複製到C:Documents and SettingslcbApplication DataMicrosoftAddInsmergebooks.dll 中。

3、安裝完成後，如果在excel2003工具欄、excel2010「載入項」中沒有以上功能按鈕，則按如下方法進行：

打開excel,在「工具欄」上點擊「COM載入項」。

PowerQuery合併利器

在微博的上看到的, http://weibo.com/1401416483/ytOmEzMVe

可以使用excel 2010的導入外部數據功能, 通過寫sql 很容易就把多個文件合併到一個文件中了. 應該是最佳答案了, 但2003可能只能用vba了. 最後我想說的用vba解決的都不是最好的方法,而是一種暴力方法.

以下，多個工作簿中的多個工作表匯總到一個工作簿中，且按工作表分開

這是很久以前網上找到的，現在不知出處了，侵刪。

Sub MergeWorkbooks()

Dim FileSet

Dim i As Integer

On Error GoTo 0

Application.ScreenUpdating = False

FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", _

MultiSelect:=True, Title:="選擇要合併的文件")

If TypeName(FileSet) = "Boolean" Then

GoTo ExitSub

End If

For Each Filename In FileSet

Workbooks.Open Filename

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

ExitSub:

Application.ScreenUpdating = True

End Sub

Sub 合併當前目錄下所有工作簿的全部工作表() Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As Long Dim BOX As String Application.ScreenUpdating = False MyPath = ActiveWorkbook.Path MyName = Dir(MyPath "" "*.xls") AWbName = ActiveWorkbook.Name Num = 0 Do While MyName &<&> "" If MyName &<&> AWbName Then Set Wb = Workbooks.Open(MyPath "" MyName) Num = Num + 1 With Workbooks(1).ActiveSheet .Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 To Sheets.Count Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1) Next WbN = WbN Chr(13) Wb.Name Wb.Close False End With End If MyName = Dir Loop Range("A1").Select Application.ScreenUpdating = True MsgBox "共合併了" Num "個工作薄下的全部工作表。如下：" Chr(13) WbN, vbInformation, "提示" End Sub

我有編過多工作薄合併到一個工作表，還有一個多工作薄分別合併到對應工作表的。

詳細可以看Q30852253空間日誌

QQ空間