多个excel文件如何快速合并到一个excel中

http://jingyan.baidu.com/article/f0062228d16ba9fbd3f0c82b.html

多个excel文件如何快速合并到一个excel中

'汇总各工作簿数据到汇总表中

Sub 汇总多工作簿()
    Dim r As Long, c As Long, str As String, sht As Worksheet
    
    '定义r，c为长整型
    r = 2
    '赋值r初值为2
    Application.ScreenUpdating = False    '屏幕闪烁关闭
    Dim filename As String, wb As Workbook, Erow As Long
    '定义filename 为文本型，wb 为 工作簿，sht为工作表，Erow 为长整型
    Dim fn As String, Arr As Variant
    'on error resume next
    On Error GoTo VeryEnd
    '程序中出现语句等运行错误时，程序跳跃到后面  VeryEnd行
    filename = Dir(ThisWorkbook.Path & "\*.xlsx")    '对文件夹内的工作簿进行循环，循环查找的格式  *.xls
    ' MsgBox filename
    Do While filename <> ""
        '对文件夹内的工作簿进行循环，截止到最后一个工作簿
        If filename <> ThisWorkbook.Name Then
        '判断文件是否是本工作簿
        'else
            '  Erow = Range("A1").End(xlDown).Row   '取得汇总表中第一条空行行号
            '  MsgBox "erow=" & Erow
            fn = ThisWorkbook.Path & "" & filename    '取得循环符合条件工作簿的  文件夹地址，赋值给fn 这个变量
            ' MsgBox "现在汇总的工作簿是fn= " & fn
            Set wb = GetObject(fn)
            '将fn代表的工作簿对象赋给变量
            Set sht = wb.Worksheets(1)
            'range,cells
            '汇总的是第1张工作表
            Arr = sht.Range("a2:m" & sht.Range("a2").End(xlDown).Row)            '将结果存放在定义好的数组arr中
            c = UBound(Arr, 1)
            ' MsgBox "现在汇总的工作簿行数= " & c
            '将数组arr中的数据写入工作表
            Range("a" & r).Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr           '将目标结果存放在目标工作表中特定的区域
            r = r + c
            '  MsgBox "现在汇总到的行数是：" & r
            wb.Close False
        End If
        filename = Dir      '进行下一步的循环
    Loop
VeryEnd:
    Application.ScreenUpdating = True
    '屏幕闪烁打开

End Sub

########################################################################################################################

Dim r As Long, c As Long, str As String, sht As Worksheet, brr(1 To Rows, 1 To 1)

########################################################################################################################

'汇总各工作簿数据到汇总表中

Sub 汇总多工作簿()
    Dim r As Long, c As Long, str As String, sht As Worksheet, brr(1 To 10000, 1 To 1)
    
    '定义r，c为长整型
    r = 2
    '赋值r初值为2
    Application.ScreenUpdating = False    '屏幕闪烁关闭
    Dim filename As String, wb As Workbook, Erow As Long
    '定义filename 为文本型，wb 为 工作簿，sht为工作表，Erow 为长整型
    Dim fn As String, Arr As Variant
    'on error resume next
    On Error GoTo VeryEnd
    '程序中出现语句等运行错误时，程序跳跃到后面  VeryEnd行
    filename = Dir(ThisWorkbook.Path & "\*.xlsx")    '对文件夹内的工作簿进行循环，循环查找的格式  *.xls
    ' MsgBox filename
    Do While filename <> ""
        '对文件夹内的工作簿进行循环，截止到最后一个工作簿
        If filename <> ThisWorkbook.Name Then
        '判断文件是否是本工作簿
        'else
            '  Erow = Range("A1").End(xlDown).Row   '取得汇总表中第一条空行行号
            '  MsgBox "erow=" & Erow
            fn = ThisWorkbook.Path & "" & filename    '取得循环符合条件工作簿的  文件夹地址，赋值给fn 这个变量
            ' MsgBox "现在汇总的工作簿是fn= " & fn
            Set wb = GetObject(fn)
            '将fn代表的工作簿对象赋给变量
            Set sht = wb.Worksheets(1)
            'range,cells
            '汇总的是第1张工作表
            
            Arr = sht.Range("a2:m" & sht.Range("a2").End(xlDown).Row)            '将结果存放在定义好的数组arr中
            c = UBound(Arr, 1)
            For i = 1 To c
                brr(i, 1) = filename
            Next
            ' MsgBox "现在汇总的工作簿行数= " & c
            '将数组arr中的数据写入工作表
            Range("b" & r).Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr           '将目标结果存放在目标工作表中特定的区域
              Range("a" & r).Resize(UBound(Arr, 1), 1) = brr
              Erase brr
            r = r + c
            '  MsgBox "现在汇总到的行数是：" & r
            wb.Close False
        End If
        filename = Dir      '进行下一步的循环
    Loop
VeryEnd:
    Application.ScreenUpdating = True
    '屏幕闪烁打开

End Sub