1、需求
如下图：一个车号一个工作表且格式一样，现根据各工作表B列日期，按照汇总表的第一行月份2019年1月、2月······统计出各车号的E列金额。麻烦各位老师帮看看怎么写代码
2、思路分析
1）汇总条件是年+月，所以需要将数据表中的相关数据按照年+月的形式汇总求和
2）将汇总后的结果与汇总条件比对，对坐入号
3）因为要对每个数据表进行日期汇总求和，所以将此功能单独剥离，主过程中调用即可，减少代码调试困难
3、代码
<code>Sub 名称汇总()
' ws_name：工作表名变量参数，字符型
' last_row: 汇总表已使用区域的总行数，数值型
' retruan_arr：接收日期汇总功能的返回值，数组类型
' dt：存储年+月的变量，字符型
Dim ws_name As String, i&, last_row&, return_arr, x&, dt As String
last_row = ActiveSheet.UsedRange.Rows.Count
Range("e2:v" & last_row).ClearContents
' return_arr接收所有数据表的返回值
ReDim return_arr(1 To last_row)
For i = 2 To last_row
ws_name = Cells(i, 3)
' 案例存在多张隐藏表，且隐藏表的结构与其他数据表结构不一，故使用隐藏判断跳过不予汇总
' 如果工作簿中无隐藏表，此判断可删除
' Visible = -1，表示工作表为可见状态
If Worksheets(ws_name).Visible = -1 Then
' 将所有的数据表（结果是一个二维数组）嵌套写入一个一维数组中，整体形成一个三维数组
return_arr(i - 1) = 日期汇总(ws_name)
End If
Next i
' 汇总表区域的日期与return_arr中的日期维度相比较，如一致则写入对应的单元格中
For i = 1 To last_row
' 汇总表的日期区域，即E1:V1区域，共计18个月
For x = 1 To 18
' 因为表中存在隐藏表，故return_arr一维数组存在空白占位元素，故须进行忽略错误处理
On Error Resume Next
' 循环return_arr每个数据表中的日期维度
For y = 1 To UBound(return_arr(i), 1)
dt = Year(Cells(1, x + 4)) & "-" & Month(Cells(1, x + 4))
If dt = return_arr(i)(y, 1) Then
' return_arr(i)(y,2)：return_arr第i个元素中第y行，第2列的元素
Cells(i + 1, x + 4) = return_arr(i)(y, 2)
End If
Next y
Next x
Next i
End Sub
Function 日期汇总(ws_name As String)
Dim arr, last_row, x&, brr(), i&, temp As String
last_row = Worksheets(ws_name).UsedRange.Rows.Count
arr = Worksheets(ws_name).Range("b2:e" & last_row)
For x = 1 To last_row
' 将2019/1/24改为年+月格式，即2019-4
temp = Year(arr(x, 1)) & "-" & Month(arr(x, 1))
On Error Resume Next
' 检测工作表的B列日期处理后的temp是否已存在于brr数组中，如存在，则对应元素累加，否则新增相应元素
' match函数的第二个参数Array必须是一维数组，而brr是二维数组，故须使用Index函数提取单维数据
' Index(brr,1,0)：brr是一个行数为2，列数不固定的数组，第一行值为日期，第二行值为金额累加值，故此句的意思即提取brr的第一行数据，也就是日期行
temp = Application.WorksheetFunction.Match(temp, Application.WorksheetFunction.Index(brr, 1, 0), 0)
' 如果元素存在数组中，则程序不报错，即Err=0，否则程序报错，Err＞0
If Err = 0 Then
brr(2, Int(temp)) = brr(2, Int(temp)) + arr(x, 4)
Else
i = i + 1
ReDim Preserve brr(1 To 2, 1 To i)
brr(1, i) = temp
brr(2, i) = arr(x, 4)
End If
Next x
' 个人习惯，将日期行与金额行转置为日期列与金额列，便于主过程使用
日期汇总 = Application.WorksheetFunction.Transpose(brr)
End Function
/<code> 
分享到:
