? ? ? 事務(wù)所底稿編制的員工，經(jīng)常需要匯總合并企業(yè)提供的Excel工作簿數(shù)據(jù)進(jìn)行數(shù)據(jù)分析慌烧，利用Excel自帶的power query合并數(shù)據(jù)時(shí)逐抑，有時(shí)會(huì)出現(xiàn)數(shù)據(jù)丟失現(xiàn)象。 孫興華老師說(shuō)pandas適用于大數(shù)據(jù)分析屹蚊，如果只是對(duì)Excel數(shù)據(jù)進(jìn)行處理厕氨，還是VBA更便捷。
匯總各工作簿汹粤，代碼默認(rèn)表頭數(shù)據(jù)為1行命斧，工作表列字段名及順序可不一致，可按需要合并工作表名稱關(guān)鍵字嘱兼，進(jìn)行工作表合并国葬，合并數(shù)據(jù)效果：
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("請(qǐng)輸入需要合并工作表名稱關(guān)鍵字" & vbCrLf & "如果未指定關(guān)鍵字默認(rèn)合并所有工作表", "提示")
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
