多个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