-
我们需要把多个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