Create two rows for each unique value in column and subtract - excel

Question

I have a list of projects in Excel. Each project has three rows (act, plan, fcst) and many columns (one column = one month).
What I would like to do is following:
A) for each unique value in column D (project #) add two rows | Completed
B) subtract plan - actual in one of new rows
C) subtract fcst - actual in second of new rows
A*) create two new rows and copy
data from columns A:AE for each unique value in column D (project #)
| Optional - I can handle option A), but A* would be a better one.
Does anyone know how to write a code to do points B, C, A*? I have no clue how to tackle that.
This is the final output that I would like to see (yellow and orange rows are new ones that I want macro to create for each unique project# in column D):
Text in AF is always either "Plan $000's" or "Actual $000's" or "Forecast $000's", for each project (i.e. each single project has these three rows; no less, no more).
Data is sorted per impact # (column D). Meaning that first three rows are related to project #123, next three are related to project #129, next three to project #761, etc.
We are allowed to play (sort, filter, etc.) with the data as long as we get the desired result. :-)
Below is the code I have right now... it is quite poor:
Sub CreateAndCompare()
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Impact")
Set rng = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp))
End With
For Each cl In rng
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, cl.Value
End If
Next cl
For Each ky In dic.keys
lastrow = ActiveSheet.Range("d2").CurrentRegion.Rows.Count
Cells(lastrow + 1, 4).Value = dic(ky)
Cells(lastrow + 2, 4).Value = dic(ky)
Next ky
End Sub
thank you!

Answer 1

I think I have found the solution. :-)
I have created an extra column AG which concatenates Impact# & Purpose (columns D&AF).
However, it takes ~15 minutes to execute the code.
Is anyone able to suggest what should I change to make it faster?
Sub CreateAndCompare()
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Impact")
Set rng = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp))
End With
For Each cl In rng
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, cl.Value
End If
Next cl
For Each ky In dic.keys
lastrow = ActiveSheet.Range("d2").CurrentRegion.Rows.Count
Cells(lastrow + 1, 4).Value = dic(ky)
Cells(lastrow + 1, 32).Value = "Act-Plan"
Cells(lastrow + 1, 33).Value = "Plan $000's"
For i = 2 To 43
mylookupvalue = Cells(lastrow + 1, 4) & "Actual $000's"
mylookupvalue_2 = Cells(lastrow + 1, 4) & Cells(lastrow + 1, 33)
myfirstcolumn = 33
mylastcolumn = 43
mycolumnIndex = i
myfirstrow = 2
mylastrow = lastrow
mytablearray = Worksheets("Impact").Range(Cells(myfirstrow, myfirstcolumn), Cells(mylastrow, mylastcolumn))
On Error Resume Next
value_1 = Application.WorksheetFunction.VLookup(mylookupvalue, mytablearray, mycolumnIndex, False)
value_2 = Application.WorksheetFunction.VLookup(mylookupvalue_2, mytablearray, mycolumnIndex, False)
Cells(lastrow + 1, i + 32).Value = value_1 - value_2
Cells(lastrow + 2, 4).Value = dic(ky)
Cells(lastrow + 2, 32).Value = "Act-Fcst"
Cells(lastrow + 2, 33).Value = "Forecast $000's"
mylookupvalue_3 = Cells(lastrow + 2, 4) & "Actual $000's"
mylookupvalue_4 = Cells(lastrow + 2, 4) & Cells(lastrow + 2, 33)
value_3 = Application.WorksheetFunction.VLookup(mylookupvalue_3, mytablearray, mycolumnIndex, False)
value_4 = Application.WorksheetFunction.VLookup(mylookupvalue_4, mytablearray, mycolumnIndex, False)
Cells(lastrow + 2, i + 32).Value = value_3 - value_4
Next i
Next ky
Worksheets("Impact").Range("AH2:BW10024").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(#_)"
End Sub

Answer 2

I suggest the following:
Loop through all data rows
Find the rows plan/actual/forecast for the current impact no
Then write the calculations to the end of the worksheet
So you would end up with something like that:
Option Explicit
Public Sub CreateAndCompare()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Impact")
'we assume here that the sheet is already sorted by column D "Impact #"
Dim LastDataRow As Long 'find last used row
LastDataRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
Dim LastDataColumn As Long 'find last used column
LastDataColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim NextEmptyRow As Long
NextEmptyRow = LastDataRow + 1
Dim iRow As Long, PlanRow As Long, ActualRow As Long, ForcastRow As Long
For iRow = 2 To LastDataRow 'loop through all data rows
Select Case ws.Cells(iRow, "AF").Value 'check which row type the current iRow is and remember
Case "Plan $000's": PlanRow = iRow
Case "Actual $000's": ActualRow = iRow
Case "Forecast $000's": ForcastRow = iRow
End Select
'detect change of impact no
If ws.Cells(iRow, "D").Value <> ws.Cells(iRow + 1, "D").Value Or iRow = LastDataRow Then
'check if plan/actual/forecast rows were found (if one is missing we cannot calculate
If PlanRow > 0 And ActualRow > 0 And ForcastRow > 0 Then
'copy column A-AE to next 2 empty rows
ws.Cells(NextEmptyRow, "A").Resize(RowSize:=2, ColumnSize:=31).Value = ws.Cells(iRow, "A").Resize(ColumnSize:=31).Value
'write purpose
ws.Cells(NextEmptyRow, "AF").Value = "Act - Plan"
ws.Cells(NextEmptyRow + 1, "AF").Value = "Act - Fcst"
'calculate
Dim iCol As Long
For iCol = 33 To LastDataColumn
ws.Cells(NextEmptyRow, iCol).Value = ws.Cells(ActualRow, iCol).Value - ws.Cells(PlanRow, iCol).Value
ws.Cells(NextEmptyRow + 1, iCol).Value = ws.Cells(ActualRow, iCol).Value - ws.Cells(ForcastRow, iCol).Value
Next iCol
NextEmptyRow = NextEmptyRow + 2 'initialize for next impact no
End If
PlanRow = 0: ActualRow = 0: ForcastRow = 0 'initialize for next impact no
End If
Next iRow
End Sub