VBA汇总多个Sheet数据

1、需求：

有1个工作簿，多个工作表，格式一致，按某列作为关键字（具有唯一性），汇总数据，以工作表名称作为汇总后的新列名称，并生成1列合计。

2、实际例子：

有1个记录员工工资的工作簿，姓名是唯一的，需要汇总每一个人当年的工资数据，举例3个月的数据：

3个月中，人员也会有变动。

需要的结果表：

3、代码实现

简单分析：

读取数据
根据姓名确定数据要存放的行号，并累加到合计列
输出

个人碰到的很多VBA实际问题基本都可以按这3步完成，所以我习惯首先把代码的框架搭好，而且我基本固定按这个模式了：

'函数返回值
Enum RetCode
    ErrRT = -1
    SuccRT = 1
End Enum
'标记一些位置信息
Enum Pos
    RowStart = 2
    
    KeyCol
    Cols
End Enum

Type DataStruct
    Src() As Variant
    Rows As Long
    Cols As Long
End Type

Sub vba_main()
    Dim d As DataStruct
    
    If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
    If RetCode.ErrRT = GetResult(d) Then Exit Sub
    
End Sub

Private Function GetResult(d As DataStruct) As RetCode

End Function

Private Function ReadSrc(d As DataStruct) As RetCode
    ReadSrc = ReadData(d.Src, d.Rows, Pos.Cols, Pos.KeyCol, Pos.RowStart)
End Function

Private Function ReadData(ByRef RetArr() As Variant, ByRef RetRow As Long, Cols As Long, KeyCol As Long, RowStart As Long) As RetCode
    ActiveSheet.AutoFilterMode = False
    RetRow = Cells(Cells.Rows.Count, KeyCol).End(xlUp).Row
    If RetRow < RowStart Then
        MsgBox "没有数据"
        ReadData = RetCode.ErrRT
        Exit Function
    End If
    RetArr = Cells(1, 1).Resize(RetRow, Cols).Value

    ReadData = RetCode.SuccRT
End Function

再根据实际需求来补充完善代码。

完善Pos枚举：

Enum Pos
    RowStart = 3
    
    序号 = 1
    姓名
    科室
    工资
    
    KeyCol = 姓名
    Cols = 工资
End Enum

注：关于代码里直接使用中文，很多人是不推荐的，因为中文Office版本下写的代码如果放到英文Office版本下会出问题，所以建议是不要使用的。

这里举例就暂不按这个要求。

因为要汇总的表格数量是不确定的，所以vba_main必须要放一个循环语句，-1是因为最后1个表格是输出的汇总表：

    For i = 1 To Worksheets.Count - 1
        If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
        If RetCode.ErrRT = GetResult(d) Then Exit Sub
    Next

输出结果我们需要姓名、合计、还有除汇总表之外每一个表都要生成的1列：

Enum PosResult
    序号 = 1
    姓名
    '多个表的列
    合计
    
    Cols
End Enum

在这么简单的一个程序里使用Enum、Type等似乎没什么必要，但是一旦养成这种好习惯，你将会发现这有很大的好处。

源表格式变化了修改方便：比如这个程序的例子，如果情况变化了，工资表里加了一列工号在姓名前面，那我们又要把程序改写了，如果代码都是按固定的列号写的，改动会比较大，但是使用了Enum的话，只需要在Enum Pos对应位置上加上工号就可以了，修改非常的方便。
输出需要新加列方便：比如我们需要把科室新增输出，只要修改PosResult，增加科室，并在GetResult里面增加一行代码就可以。

接下来就只要完成GetResult里的代码就可以了，因为需要知道某个姓名输出的行号，所以使用字典对象是再好不过了，完整代码：

Enum RetCode
    ErrRT = -1
    SuccRT = 1
End Enum

Enum Pos
    RowStart = 3
    
    序号 = 1
    姓名
    科室
    工资
    
    KeyCol = 姓名
    Cols = 工资
End Enum

Enum PosResult
    序号 = 1
    姓名
    '多个表的列
    合计
    
    Cols
End Enum

Type DataStruct
    Src() As Variant
    Rows As Long
    Cols As Long
    
    shtCount As Long
    dic As Object
    Result() As Variant
    pNextRow As Long
    pCol As Long
End Type

Sub vba_main()
    Dim d As DataStruct
    Dim i As Long
    
    Dim dic As Object
    Set d.dic = VBA.CreateObject("Scripting.Dictionary")

    d.shtCount = Worksheets.Count - 1
    '结果的行数本来应该先用字典遍历一下人名比较合适，这里就偷懒了
    '结果的列是固定要有的增加上需要处理的Sheet数量
    ReDim d.Result(1 To 1000, 1 To PosResult.Cols + d.shtCount) As Variant
    '固定列的标题
    d.Result(1, PosResult.序号) = "序号"
    d.Result(1, PosResult.姓名) = "姓名"
    d.Result(1, PosResult.合计 + d.shtCount) = "合计"
    d.pNextRow = 2
    
    For i = 1 To d.shtCount
        Worksheets(i).Activate
        If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
        d.Result(1, PosResult.姓名 + i) = Worksheets(i).Name
        d.pCol = PosResult.姓名 + i
        
        If RetCode.ErrRT = GetResult(d) Then Exit Sub
    Next
    '输出结果
    Worksheets("汇总表").Activate
    Cells.Clear
    Range("A1").Resize(d.pNextRow - 1, PosResult.Cols + d.shtCount).Value = d.Result
    
    MsgBox "OK"
End Sub

Private Function GetResult(d As DataStruct) As RetCode
    Dim i As Long
    Dim strkey As String
    Dim prow As Long
    
    For i = Pos.RowStart To d.Rows
        strkey = VBA.CStr(d.Src(i, Pos.姓名))
        If d.dic.Exists(strkey) Then
            '字典中存在当前的姓名，说明前面已经出现过了，记录前面出现的行
            prow = d.dic(strkey)
        Else
            '没有出现过的时候，就是新行输出
            prow = d.pNextRow
            '记录到字典中
            d.dic(strkey) = prow
            '添加新行的人名等信息
            d.Result(prow, PosResult.序号) = prow - 1
            d.Result(prow, PosResult.姓名) = strkey
            '新行往下移
            d.pNextRow = d.pNextRow + 1
        End If
        '添加数据
        d.Result(prow, d.pCol) = VBA.CDbl(d.Src(i, Pos.工资))
        d.Result(prow, PosResult.合计 + d.shtCount) = VBA.CDbl(d.Src(i, Pos.工资)) + d.Result(prow, PosResult.合计 + d.shtCount)
    Next
End Function

Private Function ReadSrc(d As DataStruct) As RetCode
    ReadSrc = ReadData(d.Src, d.Rows, Pos.Cols, Pos.KeyCol, Pos.RowStart)
End Function

Private Function ReadData(ByRef RetArr() As Variant, ByRef RetRow As Long, Cols As Long, KeyCol As Long, RowStart As Long) As RetCode
    ActiveSheet.AutoFilterMode = False
    RetRow = Cells(Cells.Rows.Count, KeyCol).End(xlUp).Row
    If RetRow < RowStart Then
        MsgBox "没有数据"
        ReadData = RetCode.ErrRT
        Exit Function
    End If
    RetArr = Cells(1, 1).Resize(RetRow, Cols).Value

    ReadData = RetCode.SuccRT
End Function