VBA实现多工作薄汇总

下面是我工作中，自己写的代码~今天先给大家看下，有兴趣的可以先研究下，明天我在慢慢注解下，介绍下用到的相关知识，希望你有兴趣。

Option Explicit

Sub Hb() 'Aaron(Zxl)  2016/03/28  NOC

    Application.ScreenUpdating = False

    Dim filename As String, wb As Workbook, sht As Worksheet, sht1 As Worksheet, Erow As Long

    Dim fn As String, arr As Variant

   ' Erow = ActiveWorkbook.Worksheets(1).Range('a65536').End(xlUp).Row 1

    filename = Dir(ActiveWorkbook.Path & '\*.xlsx')

    Do While filename <> ''

        If filename <> ActiveWorkbook.Name Then

            fn = ActiveWorkbook.Path & '\' & filename

            Erow = ActiveWorkbook.Worksheets(1).Range('a65536').End(xlUp).Row 1

            'MsgBox fn

            Set wb = GetObject(fn)

            Set sht = wb.Worksheets(1)

            Set sht1 = wb.Worksheets(2)

            arr = Array(sht.Range('k2'), sht.Range('g21'), sht.Range('F51'), sht.Range('d54'), sht.Range('c63'), sht.Range('c68'), sht1.Range('k4'), sht1.Range('x18'))

            Cells(Erow, 1) = arr(5)

            Cells(Erow, 2) = arr(4)

            Cells(Erow, 4) = arr(1)

            Cells(Erow, 7) = arr(2)

            Cells(Erow, 8) = arr(0)

            Cells(Erow, 12) = arr(3)

            Cells(Erow, 5) = arr(6)

            Cells(Erow, 10) = arr(7)

            wb.Close False

        End If

    filename = Dir

    'MsgBox filename

    Loop

    Application.ScreenUpdating = True

End Sub