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等似乎没什么必要,但是一旦养成这种好习惯,你将会发现这有很大的好处。
接下来就只要完成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