添加缺失的日期

Question

我有一个数据集，其中包含 10 月至 12 月 3 个月的数据（这是季度报告，因此月份会发生变化）。

示例数据：

ALB 和 ANC 分别只有 10 月和 12 月的数据。

我需要为缺失的月份添加一行。

宏应返回以下内容：

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

我的结果：

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

Answer 1

• 处理数组中的数据比逐个更新单元格更高效。

使用两个

Dictionary

对象来合并数据

• oDic1

  ：

  Col2+Date

  组合

• oDic2

  ：

  Col2

的独特列表

Option Explicit
Sub Demo()
    Dim srcSht As Worksheet, desSht As Worksheet
    Dim oDic1, oDic2, arrData, vKey, arrRes
    Dim i As Long, j As Long, endMth As Long
    Dim ColCnt As Long, sKey As String, sYr As String
    Dim lastRow As Long, iRow As Long
    Const SHT_NAME = "SubmissionForm"
    Const COL_A = "4493M"
    Const NEW_DAY = "20"
    ' Creat or clear output sheet
    On Error Resume Next
    Set desSht = Sheets(SHT_NAME)
    On Error GoTo 0
    If desSht Is Nothing Then
        Set desSht = Sheets.Add
        desSht.Name = SHT_NAME
    Else
        desSht.Cells.Clear
    End If
    Set oDic1 = CreateObject("scripting.dictionary")
    Set oDic2 = CreateObject("scripting.dictionary")
    ' Loop through worksheets
    For Each srcSht In ThisWorkbook.Worksheets
        If srcSht.Name <> SHT_NAME Then
            ' Load data
            arrData = srcSht.Range("A1").CurrentRegion.Value
            ColCnt = UBound(arrData, 2)
            If UBound(arrData) > 1 Then
                If IsDate(arrData(2, 1)) Then
                    ' the current year
                    sYr = Right(CStr(Year(arrData(2, 1))), 2)
                    ' the last month of the qtr
                    endMth = ((Month(arrData(2, 1)) + 2) \ 3) * 3
                    oDic1.RemoveAll
                    oDic2.RemoveAll
                    ' Loop through data
                    For i = LBound(arrData) + 1 To UBound(arrData)
                        vKey = arrData(i, 2)
                        If Not oDic2.exists(vKey) Then
                            ' Unique list of Col2
                            oDic2(vKey) = ""
                            ' Unique list of Col2 & mth combination
                            For j = endMth - 2 To endMth
                                sKey = vKey & "|" & j
                                oDic1(sKey) = 0
                            Next
                        End If
                        sKey = arrData(i, 2) & "|" & Month(arrData(i, 1))
                        If oDic1.exists(sKey) Then oDic1(sKey) = i
                    Next i
                    ReDim arrRes(1 To oDic1.Count, 1 To ColCnt + 1)
                    i = 1
                    ' Populate the output array arrRes
                    For Each vKey In oDic1.Keys
                        arrRes(i, 1) = COL_A
                        arrRes(i, 2) = Split(vKey, "|")(0)
                        arrRes(i, 3) = Split(vKey, "|")(1) & NEW_DAY & sYr
                        iRow = oDic1(vKey)
                        If iRow = 0 Then
                            For j = 3 To ColCnt
                                arrRes(i, j + 1) = 0
                            Next j
                        Else
                            For j = 3 To ColCnt
                                arrRes(i, j + 1) = arrData(iRow, j)
                            Next j
                        End If
                        i = i + 1
                    Next
                End If
            End If
            ' Write output to sheet
            lastRow = desSht.Cells(desSht.Rows.Count, "A").End(xlUp).Row
            If lastRow > 1 Or Len(desSht.Cells(lastRow, 1)) > 0 Then lastRow = lastRow + 1
            desSht.Cells(lastRow, 1).Resize(UBound(arrRes), UBound(arrRes, 2)).Value = arrRes
        End If
    Next
    Dim c As Range
    ' Fill blank
    Set c = desSht.UsedRange.SpecialCells(xlCellTypeBlanks)
    If Not c Is Nothing Then c.Value = 0
End Sub