如何使用VBA将Excel表格周度工时数据转换为月度汇总数据

实现思路 #

• 读取原表所有周列的起始日期（周日），匹配每个周列对应的年月
• 对所有年月去重，得到需要输出的月度列列表
• 逐行遍历原表数据，按年月分组累加对应周列的工时值
• 将结果输出到新工作表，表头为mmm-yy格式的月度名称

你现有代码的小问题：format是VBA内置函数名，不可以作为变量名使用，会导致语法错误，建议改为其他变量名比如dateFmt。

完整实现代码 #

Sub 周度工时转月度汇总()
    Dim srcSheet As Worksheet, resSheet As Worksheet
    Dim lastCol As Long, lastRow As Long, i As Long, j As Long
    Dim weekStart As Date, monthKey As String
    Dim monthMap As Object ' 存储月份对应的周列索引集合
    Dim resColCount As Long
    
    ' 配置参数，可根据实际表格调整
    Const HEADER_ROW = 1 ' 周日期表头所在行号
    Const DATA_START_ROW = 2 ' 数据起始行号
    Const DATA_START_COL = 2 ' 周数据起始列号（左侧固定列比如人员、项目名不用统计，所以从该列开始算周列）
    
    Set srcSheet = ActiveSheet ' 可替换为你实际的原表名，比如Sheets("周度工时")
    Set monthMap = CreateObject("Scripting.Dictionary")
    
    ' 获取原表最大行、列号
    lastCol = srcSheet.Cells(HEADER_ROW, srcSheet.Columns.Count).End(xlToLeft).Column
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
    
    ' 遍历所有周列，按归属月份分组
    For j = DATA_START_COL To lastCol
        weekStart = srcSheet.Cells(HEADER_ROW, j).Value
        monthKey = Format(weekStart, "mmm-yy") ' 生成和需求一致的月度列名，比如Oct-21
        ' 新月份则初始化存储
        If Not monthMap.Exists(monthKey) Then
            monthMap(monthKey) = Array()
        End If
        ' 将当前周列索引加入对应月份的数组
        Dim tmpArr As Variant
        tmpArr = monthMap(monthKey)
        ReDim Preserve tmpArr(UBound(tmpArr) + 1)
        tmpArr(UBound(tmpArr)) = j
        monthMap(monthKey) = tmpArr
    Next j
    
    ' 创建结果工作表
    Set resSheet = ThisWorkbook.Sheets.Add(After:=srcSheet)
    resSheet.Name = "月度汇总_" & Format(Now, "YYYYMMDDHHMM")
    
    ' 复制左侧固定列（比如人员、项目名）
    srcSheet.Range(srcSheet.Cells(1, 1), srcSheet.Cells(lastRow, 1)).Copy resSheet.Cells(1, 1)
    
    ' 写入月度表头
    resColCount = 1
    For Each monthKey In monthMap.Keys
        resColCount = resColCount + 1
        resSheet.Cells(HEADER_ROW, resColCount) = monthKey
    Next
    
    ' 逐行计算月度汇总值
    For i = DATA_START_ROW To lastRow
        resColCount = 1
        For Each monthKey In monthMap.Keys
            resColCount = resColCount + 1
            Dim total As Double
            total = 0
            ' 累加当前月份所有周列的数值
            For Each j In monthMap(monthKey)
                total = total + Val(srcSheet.Cells(i, j).Value)
            Next j
            resSheet.Cells(i, resColCount) = total
        Next monthKey
    Next i
    
    ' 自动调整列宽
    resSheet.Columns.AutoFit
    MsgBox "月度汇总完成，结果已保存至工作表：" & resSheet.Name, vbInformation
End Sub

注意事项 #

• 代码开头的三个常量参数需要根据你的实际表格结构调整，比如周日期表头在第2行、数据从第3行开始、左侧有2列固定信息，对应修改参数值即可
• 若需要按周结束日（周六）归属月份，只需将weekStart = srcSheet.Cells(HEADER_ROW, j).Value修改为weekStart = srcSheet.Cells(HEADER_ROW, j).Value + 6
• 若周列表头不是标准日期格式，需要先将表头转换为日期类型再运行代码，避免匹配错误
• 该代码兼容所有Excel版本，无需额外依赖

内容的提问来源于stack exchange，提问作者Ross