Transform Pure activities data by filling in rows with missing year

addMissingYears.vb

Public Sub addMissingYears()

    Dim readFrom As Long 'Row we read from
    Dim writeTo As Long 'Row we write to
    Dim allRows As Long 'Row count to loop over
    Dim thisC As Long
    Dim thisD As Long
    Dim sheetFrom As Worksheet 'Sheet where we read from
    Dim sheetTo As Worksheet 'Sheet where we write to
        
        
    Set sheetFrom = Sheets("Activities")
    allRows = sheetFrom.UsedRange.Rows.Count
    readFrom = 2
    writeTo = 2
        
    'Add new sheet
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "ActivitiesNew"
    Set sheetTo = Sheets("ActivitiesNew")
    
    'Add header row
    sheetTo.Cells(1, 1).Value = sheetFrom.Cells(1, 1)
    sheetTo.Cells(1, 2).Value = sheetFrom.Cells(1, 2)
    sheetTo.Cells(1, 3).Value = sheetFrom.Cells(1, 3)
    sheetTo.Cells(1, 4).Value = sheetFrom.Cells(1, 4)
    
    'Compare C and D.
    'If C=D or D is empty, copy row.
    'If C<D, add a new row until C=D, copy cells from A and B.
    'For example:
    'TypeA, UnitX, 2010, 2013 ->
    'TypeA, UnitX, 2010, 2010
    'TypeA, UnitX, 2011, 2011
    'TypeA, UnitX, 2012, 2012
    'TypeA, UnitX, 2013, 2013
    
    For j = readFrom To allRows
    
        'C=D or D is empty
        If (sheetFrom.Range("C" & j).Value = sheetFrom.Range("D" & j).Value) Or sheetFrom.Range("D" & j).Value = "" Then
           sheetTo.Range("A:D").Rows(writeTo).Value = sheetFrom.Range("A:D").Rows(j).Value
           
           writeTo = writeTo + 1
           
        'C<D and D is not empty
        ElseIf (CLng(sheetFrom.Range("C" & j).Value) < CLng(sheetFrom.Range("D" & j).Value)) And sheetFrom.Range("D" & j).Value <> "" Then
        
             'First, copy the row but replace D with C
             sheetTo.Range("A:C").Rows(writeTo).Value = sheetFrom.Range("A:C").Rows(j).Value
             sheetTo.Cells(writeTo, 4).Value = sheetFrom.Cells(j, 3).Value
             
             'Then, add new rows by increasing the value of C by 1 until the value of D is reached
             thisC = CLng(sheetFrom.Range("C" & j).Value) + 1
             thisD = CLng(sheetFrom.Range("D" & j).Value)
             writeTo = writeTo + 1
             
             While thisC <= thisD
                sheetTo.Range("A:B").Rows(writeTo).Value = sheetFrom.Range("A:B").Rows(j).Value
                sheetTo.Cells(writeTo, 3).Value = thisC
                sheetTo.Cells(writeTo, 4).Value = thisC
                thisC = thisC + 1
                writeTo = writeTo + 1
             Wend
             
        End If
        
    Next j
     
End Sub