Skip to content

Instantly share code, notes, and snippets.

@tts
Last active July 11, 2017 14:30
Show Gist options
  • Save tts/f563902a33ce53e6d36d6e47068d17af to your computer and use it in GitHub Desktop.
Save tts/f563902a33ce53e6d36d6e47068d17af to your computer and use it in GitHub Desktop.
Transform Pure activities data by filling in rows with missing year
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment