事务所底稿编制的员工，经常需要汇总合并企业提供的Excel工作簿数据进行数据分析，利用Excel自带的power query合并数据时，有时会出现数据丢失现象。 孙兴华老师说pandas适用于大数据分析，如果只是对Excel数据进行处理，还是VBA更便捷。
汇总各工作簿，代码默认表头数据为1行，工作表列字段名及顺序可不一致，可按需要合并工作表名称关键字，进行工作表合并，合并数据效果：
VBA代码如下：
Sub CollectWorkBookDatas()
Dim shtActive As Worksheet, rng As Range, shtData As Worksheet
Dim nTitleRow As Long, nLastRow As Long
Dim i, k, y As Long
Dim aData, aRes
Dim strPath As String, strFileName As String
Dim strKey, strk As String, nShtCount As Long
With Application.FileDialog(msoFileDialogFolderPicker)
Set d = CreateObject("scripting.dictionary")
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strk = InputBox("请输入需要合并工作表名称关键字" & vbCrLf & "如果未指定关键字默认合并所有工作表", "提示")
If StrPtr(strk) = 0 Then Exit Sub
Set shtActive = ActiveSheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
Cells.NumberFormat = "@"
Cells.Clear
strFileName = Dir(strPath & "*.xls*")
k = 2
Do While strFileName <> ""
With GetObject(strPath & strFileName)
For Each shtData In .Worksheets
If InStr(1, shtData.Name, strk, vbTextCompare) Then
If shtData.FilterMode = True Then shtData.Cells.AutoFilter
Set rng = shtData.UsedRange
If rng.Count > 1 Then
N = N + 1
aData = rng.Value
ReDim aRes(1 To UBound(aData), 1 To k)
For j = 1 To UBound(aData, 2)
strKey = aData(1, j)
If Not d.Exists(strKey) Then
k = k + 1
If k > UBound(aRes, 2) Then
ReDim Preserve aRes(1 To UBound(aRes), 1 To k)
End If
d(strKey) = k
End If
y = d(strKey)
For i = 2 To UBound(aData)
aRes(i - 1, y) = aData(i, j)
Next
Next
For i = 2 To UBound(aData)
aRes(i - 1, 1) = strFileName
aRes(i - 1, 2) = shtData.Name
Next
intLastRow = shtActive.Cells(Rows.Count, 1).End(xlUp).Row + 1
shtActive.Cells(intLastRow, 1).Resize(UBound(aRes), UBound(aRes, 2)) = aRes
End If
End If
Next
.Close False
End With
strFileName = Dir()
Loop
shtActive.Select
Range("a1") = "工作表名"
Range("b1") = "工作簿名"
Range("C1").Resize(1, k - 2) = d.Keys
Set d = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
End With
MsgBox "共汇总 " & N & "张工作表"
End Sub
