Excel300個工作簿裡2000個表複製到一個表，我只需3分鐘

1

昨天發過一種vba方法，把一個工作簿裡上百個分表複製粘貼到當前工作簿的總表裡，

只要幾秒鐘。

見這篇文章：

100個工作表，數據瞬間彙集到一個總表裡，我只需要1秒！

今天給大家介紹另外一種絕招！神技！彪悍的人生無需解釋！

假設你有幾十個甚至幾百個工作簿，每個工作簿裡有若干表（少則一個，多則十幾個工作表，每個表的數據結構相同，數據記錄條數不等），現在你需要把這些工作簿裡的每個工作表裡的數據，複製粘貼到一個新工作簿的一個空白表裡。

如果你有300個工作簿，每個工作簿裡有7個工作表。假設這2000多個工作表裡的數據記錄（記錄條數總數最多不能超過104萬行，因為xlsx格式的單表最多行數是1048576行）都被複制粘貼到一個新工作簿裡的某個空白表裡，如果純粹手工複製粘貼，操作熟練快速，中間不出任何差錯，我毛估時間至少得10-15個小時。

也就是說你可能得機械地複製粘貼1-2個工作日的上班時間，中間不能有任何錯誤，否則可能意味著要檢查甚至重新複製粘貼。

想必，有很多朋友這麼幹過。這麼做過的人，都明白，枯躁乏味，苦不堪言，但卻又無能為力！

2

下面是案例背景。

有300個工作簿，每個工作簿大概3-6個工作表不等，數據記錄都是500行。

這些工作簿存儲在某盤文件夾“多工作簿多表超級彙集”下的子文件夾“明細表”裡

下面是其中一個工作簿裡的一個工作表數據，記錄數有500條。↓

而彙總表就存在“多工作簿多表超級彙集”這個文件夾下，見下圖

3

打開工作簿“彙總表.xlsxm” (帶VBA程序的excel工作簿應該保存為這種格式)

先學習第一種方法，在“總表”這個工作表裡設置好表頭，調整好列寬和格式，繪製好圓角矩形作為宏代碼的執行按鈕。

按ALT+F11，插入，模塊，把以下代碼複製到模塊1裡

Sub 彙總不帶表名()

Dim wb, mypath, myfile, sh, zong

t = Timer '開始時間

Set zong = Sheets("總表")

zong.UsedRange.Offset(1, 0).ClearContents

mypath = ThisWorkbook.Path & "\明細表"

myfile = Dir(mypath & "*.xlsx")

Do While myfile <> ""

Set wb = GetObject(mypath & myfile)

For Each sh In wb.Worksheets

On Error Resume Next

With sh

.UsedRange.Offset(1, 0).Copy zong.Cells(Range("a" & Rows.Count).End(xlUp).Row + 1, 1)

End With

Next

wb.Close False

myfile = Dir

Loop

Set wb = Nothing

MsgBox "數據合併用時：" & Format(Timer - t, "#0.000") & " 秒", , "則見溫馨提示：彙總完成！每一天都是美妙的！"

End Sub

然後，關閉vba編輯窗口。右鍵單擊按鈕，指定宏，選擇“彙總不帶表名”，確定。

單擊“提取”按鈕，程序開始執行，大約6-7秒時間彙總完畢。時間長短取決於電腦內存以及彙總的工作表的數量（這裡為了簡化起見，只保留了7個工作簿，所以時間比較短，只有幾秒鐘）。

“總表”裡的結果，是通過代碼把各個表裡的數據直接粘貼過來，沒有考慮每個工作表的表名。

4

接下來再介紹一種vba寫法，很多寫法和上一種類似，就是加了增加表名作為列字段。

Sub 彙集帶表名()

Dim wb, hui, mypath, myfile, sh, myirow, newirow

t = Timer '開始時間

Set hui = Sheets("彙集")

hui.UsedRange.Offset(1, 0).ClearContents

mypath = ThisWorkbook.Path & "\明細表"

myfile = Dir(mypath & "*.xlsx")

Do While myfile <> ""

Set wb = GetObject(mypath & myfile)

For Each sh In wb.Worksheets

On Error Resume Next

With sh

myirow = hui.Range("B" & Rows.Count).End(xlUp).Row + 1

.UsedRange.Offset(1, 0).Copy hui.Cells(myirow, 2)

newirow = hui.Range("B" & Rows.Count).End(xlUp).Row

hui.Range("A" & myirow & ":A" & newirow) = sh.Name

End With

Next

wb.Close False

myfile = Dir

Loop

Set wb = Nothing

MsgBox "數據合併用時：" & Format(Timer - t, "#0.000") & " 秒", , "則見溫馨提示：彙總完成！每一天都是美妙的！"

End Sub

其他細節略。

點擊“超級匯”按鈕，大概3分鐘不到執行完畢。

執行時間總共160多秒。因為這裡測試用到的要提取數據的工作簿個數是300個（工作表總數大概2000個）。

最後提取的記錄數右789000行。

複製粘貼2000個工作表到一個總表裡來，不過3分鐘！

提醒下，是從300個工作簿裡，複製粘貼到“彙集”表裡的！

提醒下，“彙集”總表裡，還增加一列城市字段，其實就是2000個工作表的表名！

如果全部靠人工來複制粘貼，那麼15個小時-20個小時是跑不掉的！

而且做這個工作的人，簡直痛不欲生，無語凝噎，估計雙手都得抽筋！

但是，我們這段代碼，只需要3分鐘！

只需要180秒！

只需要180秒！

只需要180秒！

再不學習，還想又快又好，還想升職加薪，簡直痴人說夢！

End.

來源：公眾號“Excel和PPT職場見”

運行人員：中國統計網小編（微信號：itongjilove）

微博ID：中國統計網

中國統計網，是國內最早的大數據學習網站，公眾號：中國統計網

http://www.itongji.cn