合并多个excel文件内容

1. 我们需要把多个excel表都放在同一个文件夹里面，并在这个文件夹里面新建一个excel。

   
   

   
   

2. 用microsoft excel打开新建的excel表，并右键单击sheet1，找到“查看代码”，单击进去。进去之后就看到了宏计算界面。

   
   

3. 然后我们把下面这些宏计算的代码复制进去，然后找到工具栏上面的“运行”下的“运行子过程/用户窗体”，代码如下。

   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

   
   

   
   

4. 运行之后，等待10秒针左右，等运行完毕，就是合并完成之后，会有提示，点确定就可以了。查看合并后的数据，有5000多行，就是同一个文件夹里面17个excel表数据合并后的结果。效果如图所示。

-------------------------------------------------------------自己完成作品的宏---------------------------------------------------------------------------------------

'This macro is combining all data from different excel in a same folder'Stones create on 2017/3/3Sub 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 & "\" & "*.csv")     ActiveWbName = ActiveWorkbook.Name    FileNum = 0    '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                'Close workbook without saving        Wb.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.SaveEnd Sub

'This macro is combining all data from different excel in a same folder'Stones createSub 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.SaveEnd Sub