Excel VBA宏开发需求：为季度报表补全缺失月份数据

我手头有一份季度报表数据集（当前为10-12月，月份会随季度调整），其中ALB只有10月的记录、ANC只有12月的记录。需要补全这两个主体缺失月份的行，且缺失行的所有数值都设为0。预期输出格式如下：

ALB,102023,9,2,0,0,9,9,.22,8.78
ALB,112023,0,0,0,0,0,0,0,0
ALB,122023,0,0,0,0,0,0,0,0
ANC,102023,0,0,0,0,0,0,0,0
ANC,112023,0,0,0,0,0,0,0,0
ANC,122023,3,1,0,0,3,3,.11,2.89

我写了下面这段VBA宏，但没能实现预期效果，需要修正代码来达成需求：

Sub FormatData()
    Dim ws As Worksheet
    Dim destWs As Worksheet
    Dim lastRow As Long
    Dim destRow As Long
    
    ' Set the destination worksheet
    Set destWs = Sheets.Add
    destWs.Name = "SubmissionForm" ' You can change the name if needed
    
    ' Loop through each worksheet in the workbook
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> destWs.Name Then ' Exclude the destination sheet
            destRow = 1 ' Start from the first row in the destination sheet
            
            ' Find the last row with data in the current sheet
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            ' Loop through each row in the current sheet
            For i = 2 To lastRow ' Assuming data starts from the second row
            
                ' Format the data and write to the destination sheet
                destWs.Cells(destRow, 1).Value = "4493M"
                destWs.Cells(destRow, 2).Value = IIf(ws.Cells(i, 2).Value = "", 0, ws.Cells(i, 2).Value)
                destWs.Cells(destRow, 3).Value = Format(ws.Cells(i, 1).Value, "mmyyyy")
                destWs.Cells(destRow, 4).Value = IIf(ws.Cells(i, 3).Value = "", 0, ws.Cells(i, 3).Value)
                destWs.Cells(destRow, 5).Value = IIf(ws.Cells(i, 4).Value = "", 0, ws.Cells(i, 4).Value)
                destWs.Cells(destRow, 6).Value = IIf(ws.Cells(i, 5).Value = "", 0, ws.Cells(i, 5).Value)
                destWs.Cells(destRow, 7).Value = IIf(ws.Cells(i, 6).Value = "", 0, ws.Cells(i, 6).Value)
                destWs.Cells(destRow, 8).Value = IIf(ws.Cells(i, 7).Value = "", 0, ws.Cells(i, 7).Value)
                destWs.Cells(destRow, 9).Value = IIf(ws.Cells(i, 8).Value = "", 0, ws.Cells(i, 8).Value)
                destWs.Cells(destRow, 10).Value = IIf(ws.Cells(i, 9).Value = "", 0, ws.Cells(i, 9).Value)
                destWs.Cells(destRow, 11).Value = IIf(ws.Cells(i, 10).Value = "", 0, ws.Cells(i, 10).Value)
                
                destRow = destRow + 1 ' Move to the next row in the destination sheet
            Next i
        
        Else
            ' If no data for the month, add a line with all values set to 0
            destWs.Cells(destRow, 1).Value = "4493M"
            destWs.Cells(destRow, 2).Value = ws.Cells(i, 2).Value
            destWs.Cells(destRow, 3).Value = Format(ws.Cells(i, 1).Value, "mmyyyy")
            destWs.Cells(destRow, 4).Value = 0
            destWs.Cells(destRow, 5).Value = 0
            destWs.Cells(destRow, 6).Value = 0
            destWs.Cells(destRow, 7).Value = 0
            destWs.Cells(destRow, 8).Value = 0
            destWs.Cells(destRow, 9).Value = 0
            destWs.Cells(destRow, 10).Value = 0
            destWs.Cells(destRow, 11).Value = 0
                    
            destRow = destRow + 1 ' Move to the next row in the destination sheet
        End If

    Next ws
End Sub

修正后的VBA宏 #

Sub FormatData()
    Dim ws As Worksheet
    Dim destWs As Worksheet
    Dim lastRow As Long
    Dim destRow As Long
    Dim i As Long, j As Long
    Dim entityName As String
    Dim quarterMonths As Variant
    Dim existingMonths As Collection
    Dim monthYear As String
    Dim currentMonthYear As String
    
    ' 定义当前季度的月份（可根据季度调整，如Q1改为Array("012024", "022024", "032024")）
    quarterMonths = Array("102023", "112023", "122023")
    
    ' 创建/获取目标工作表
    On Error Resume Next
    Set destWs = ThisWorkbook.Sheets("SubmissionForm")
    If Err.Number <> 0 Then
        Set destWs = Sheets.Add
        destWs.Name = "SubmissionForm"
    End If
    On Error GoTo 0
    destWs.Cells.Clear ' 清空目标表原有数据
    
    destRow = 1 ' 目标表起始行
    
    ' 遍历每个数据工作表（假设每个工作表对应一个实体，如ALB、ANC）
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> destWs.Name Then
            ' 收集当前工作表中已有的月份
            Set existingMonths = New Collection
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            For i = 2 To lastRow
                currentMonthYear = Format(ws.Cells(i, 2).Value, "mmyyyy") ' 假设B列是日期，转为mmyyyy格式
                On Error Resume Next
                existingMonths.Add currentMonthYear, Key:=currentMonthYear
                On Error GoTo 0
            Next i
            
            entityName = ws.Cells(2, 1).Value ' 获取当前实体名称（如ALB）
            
            ' 遍历季度所有月份，补全数据
            For Each monthYear In quarterMonths
                ' 写入实体名称和月份
                destWs.Cells(destRow, 1).Value = entityName
                destWs.Cells(destRow, 2).Value = monthYear
                
                ' 检查当前月份是否有数据
                Dim hasData As Boolean
                hasData = False
                For i = 2 To lastRow
                    currentMonthYear = Format(ws.Cells(i, 2).Value, "mmyyyy")
                    If currentMonthYear = monthYear Then
                        ' 有数据，复制对应列值，空值设为0
                        For j = 3 To 10 ' 对应示例中第3到第10列的数值项
                            destWs.Cells(destRow, j + 1).Value = IIf(ws.Cells(i, j).Value = "", 0, ws.Cells(i, j).Value)
                        Next j
                        hasData = True
                        Exit For
                    End If
                Next i
                
                ' 无数据则全部填充0
                If Not hasData Then
                    For j = 3 To 10
                        destWs.Cells(destRow, j + 1).Value = 0
                    Next j
                End If
                
                destRow = destRow + 1
            Next monthYear
        End If
    Next ws
End Sub

核心修正说明 #

• 逻辑重构：原代码Else分支逻辑完全错误，无法识别缺失月份。改为先收集每个实体已有的月份，再遍历季度所有月份，对比后补全缺失行。
• 季度适配：新增quarterMonths数组，直接修改数组内容即可适配不同季度，无需改动核心逻辑。
• 实体匹配：假设每个工作表对应一个实体（如ALB单独在一个表），遍历季度所有月份，存在数据则复制并处理空值，不存在则统一填充0。
• 目标表优化：新增目标表存在性检查，避免重复创建；清空原有数据，防止残留旧内容。

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