-
我們需要把多個excel表都放在同一個文件夾裏面，並在這個文件夾裏面新建一個excel。
-
用microsoft excel打開新建的excel表，並右鍵單擊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("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合併了" & Num & "個工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
-
運行之後，等待10秒針左右，等運行完畢，就是合併完成之後，會有提示，點確定就可以了。查看合併後的數據，有5000多行，就是同一個文件夾裏面17個excel表數據合併後的結果。效果如圖所示。
-------------------------------------------------------------自己完成作品的宏---------------------------------------------------------------------------------------
'This macro is combining all data from different excel in a same folder
'Stones create on 2017/3/3
Sub CombineData()
'define variable
Dim FilePath, SingleFileName, ActiveWbName
Dim TraverseBook As Workbook, ALLWbName As String
Dim FileNum As Long
'stop screen-updating for user so program runs more fast
Application.ScreenUpdating = False
'get file path
FilePath = ActiveWorkbook.Path
SingleFileName = Dir(FilePath & "\" & "*.xlsx")
ActiveWbName = ActiveWorkbook.Name
FileNum = 0
'traverse all different work book
Do While SingleFileName <> ""
If SingleFileName <> ActiveWbName Then
Set TraverseBook = Workbooks.Open(FilePath & "\" & SingleFileName)
'count file number
FileNum = FileNum + 1
'get all workbook name
ALLWbName = ALLWbName & Chr(13) & TraverseBook.Name
'Close workbook without saving
TraverseBook.Close False
End If
'reset next file name into SingleFileName variable
SingleFileName = Dir
Loop
'show the result
Application.ScreenUpdating = True
MsgBox "combined" & FileNum & "excel as following:" & Chr(13) & ALLWbName, vbInformation, "notification"
'***auto save combine excel
'save change in active workbook
'ActiveWorkbook.Save
End Sub
'This macro is combining all data from different excel in a same folder
'Stones create
Sub CombineData()
'define variable
Dim FilePath, SingleFileName, ActiveWbName
Dim Wb As Workbook, ALLWbName As String
Dim FileNum As Long
'stop scrrenupdating for user so program runs more fast
Application.ScreenUpdating = False
'get file path
FilePath = ActiveWorkbook.Path
SingleFileName = Dir(FilePath & "\" & "*.xlsx")
ActiveWbName = ActiveWorkbook.Name
FileNum = 0
'last row index of combine excel active sheet
Dim ComLastRowIndex As Long
ComLastRowIndex = 6
'shee2 last row index of conbine excel active sheet
Dim sheet2RowIndex As Long
sheet2RowIndex = 2
'BC in very single excel
Dim sinBC As String
'BU in every single excel
Dim sinBU As String
'Country in very single excel
Dim sinCountry As String
'traverse all different work book
Do While SingleFileName <> ""
If SingleFileName <> ActiveWbName Then
Set Wb = Workbooks.Open(FilePath & "\" & SingleFileName)
'count file number
FileNum = FileNum + 1
'get all workbook name
ALLWbName = ALLWbName & Chr(13) & Wb.Name
'get BC BU Country in every single excel then put into Q R S column
sinBC = Mid(Wb.Name, 37, 3)
sinBU = Mid(Wb.Name, 30, 3)
sinCountry = Mid(Wb.Name, 5, 5)
'open Top 20 Past Due Customers sheet
Sheets("Top 20 Past Due Customers").Select
'unhide all rows
Rows("1:" & ActiveSheet.Rows.Count).Select
Selection.EntireRow.Hidden = False
'aging table which last row index of B column including customer name
Dim SinAgingLastRowIndex As Long
SinAgingLastRowIndex = 6
'******Aging table******
'get last row index in aging table every single Excel
Do While Range("B" & SinAgingLastRowIndex) <> ""
SinAgingLastRowIndex = SinAgingLastRowIndex + 1
Loop
'if single excel has actual data then copy the data
If SinAgingLastRowIndex > 6 Then
'select aging data area A6 - P *
'Range("A6:P*").Select
Range("A6:P" & (SinAgingLastRowIndex - 1)).Select
Selection.Copy
'jump to conbine excel
Workbooks("combine.xlsm").Activate
Sheets("1").Select
'find A column to paste
Range("A" & ComLastRowIndex).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'set BU BC values in Q(BC) & R(BU) column
Range("Q" & ComLastRowIndex & ":Q" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinBC
Range("R" & ComLastRowIndex & ":R" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinBU
Range("S" & ComLastRowIndex & ":S" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinCountry
'reset combine excel lastRowIndex by adding new row number
ComLastRowIndex = ComLastRowIndex + SinAgingLastRowIndex - 6
End If
'******No Balance table******
'jump to single excel window to copy no balance data
Wb.Activate
'No Balance table which start and last row index of B column
Dim SinNBalStartIndex As Long
Dim SinNBalLastRowIndex As Long
SinNBalLastRowIndex = 0
'find fixed cell , get row number of cell
SinNBalStartIndex = Cells.Find(What:="Accounts below the threshold. No commentary needed", MatchCase:=False).Row + 1
'find no balance table last row index of every single Excel
SinNBalLastRowIndex = Cells.Find(What:="Grand Totals", MatchCase:=False).Row - 1
'if no balance table has data then copy the data
If SinNBalStartIndex <= (SinNBalLastRowIndex) Then
Range("A" & SinNBalStartIndex & ":P" & (SinNBalLastRowIndex)).Select
Selection.Copy
'jump to conbine excel
Workbooks("combine.xlsm").Activate
Sheets("2").Select
Range("A" & sheet2RowIndex).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'set BC BU Country valuses in Q & R & S column
'Range ("Q" & sheet2RowIndex & ":Q" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex + 1 - 1))
Range("Q" & sheet2RowIndex & ":Q" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinBC
Range("R" & sheet2RowIndex & ":R" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinBU
Range("S" & sheet2RowIndex & ":S" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinCountry
'get sheet2 start place to paste no balace data for next time
sheet2RowIndex = sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex + 1
End If
'Close workbook without saving
Wb.Close False
End If
'reset next file name into SingleFileName variable
SingleFileName = Dir
Loop
'******Cope sheet2 to sheet1******
Range("A1:S" & sheet2RowIndex).Copy
Sheets("1").Select
Range("A" & (ComLastRowIndex + 2)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'show the result
Application.ScreenUpdating = True
MsgBox "combined" & FileNum & "excel as following:" & Chr(13) & ALLWbName, vbInformation, "notification"
'***auto save combine excel
'save change in active workbook
'ActiveWorkbook.Save
End Sub
