合并多个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/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