多工作簿合并计算

Public Sub QuickConsolidateMethod()

    '声明变量

    Dim Wb As Workbook, OpenWb As Workbook

    Dim Sht As Worksheet, OneSht As Worksheet

    Dim Rng As Range, OneRng As Range, RangeAddress As String

    Const SHEET_INDEX = 1

    Const RANGE_ADDRESS = "C5:L17"

    Dim FirstCell As Range

    Dim Arr() As String

    ReDim Arr(1 To 1)

    Dim FolderPath, FileName, FileIndex

    '设置对象

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.ActiveSheet

    Set Rng = Sht.Range(RANGE_ADDRESS)

    Set FirstCell = Rng.Cells(1, 1) '合计结果输出位置的左上角

    RangeAddress = Rng.Address(ReferenceStyle:=xlR1C1) '选用指定格式的单元格地址

    

    FolderPath = Wb.Path & "各部门" '各部门工作簿文件夹

    FileIndex = 0

    FileName = Dir(FolderPath & "*.xls*")

    Do While FileName <> ""

        FileIndex = FileIndex + 1

        ReDim Preserve Arr(1 To FileIndex)

        Set OpenWb = Application.Workbooks.Open(FolderPath & FileName) '若工作表已经有统一名称，则不需要打开

        Set OneSht = OpenWb.Worksheets(SHEET_INDEX)

        Arr(FileIndex) = "'" & FolderPath & "[" & FileName & "]" & OneSht.Name & "'!" & RangeAddress '构造引用地址

        OpenWb.Close False '关闭文件

        FileName = Dir

    Loop

    '执行合并计算方法

    FirstCell.Consolidate Sources:=Arr, Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:=False

    '释放对象

    Set Wb = Nothing: Set Sht = Nothing

    Set Rng = Nothing: Set OpenWb = Nothing

    Set OneSht = Nothing

End Sub