Adding missing dates

Question

I have a dataset that has data for 3 months, October - December (this is a quarterly report so months will change).

Example data:

ALB and ANC only have data for October and December, respectively.

I need to add a line for the missing months.

The macro should return the following:

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

My results:

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

• Processing data in arrays is more efficient than update cells one by one.

Use two Dictionary objects to consolidate data

• oDic1: Col2+Date combination
• oDic2: the unique list of 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