Hi Eric,
Thank you again for all your help! I’ve tested the code and had to do some adjustments for the change in data I mentioned earlier. However, I having problems executing.
I split it into 2 different modules. The first model only runs the code through row 333. This is because I need SL (L4:O4) to be part of the variables for the first section of the P&L but not for the second section (rows 334 and below). In order to accommodate column J in Sheet2 (“Code”) like Accounts are handled, in this first module I had to change the code from:
d1 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12)) & "|" & MyData(i, 15)
to
d1 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12)) & "|" & CLng(MyData(i, 13))
and
d1 = CLng(acct) & "|" & Month(mdate) & "|" & Year(mdate) & "|" & LCase(CStr(mdate.Offset(-1))) & "|" & acc.offset(, 1) & "|" & acc.offset(, 2)
to
d1 = CLng(acct) & "|" & Month(mdate) & "|" & Year(mdate) & "|" & LCase(CStr(mdate.Offset(-1))) & "|" & acct.offset(, 3)
Please note I had to type a “t” in acct.offset(, 3) in order to make it work…not sure if this is correct. However it did pull the numbers correctly. The problem is that it took over 5 minutes for the code to run. As this is a file used for forecasting purposes during crunch time I’m afraid we wouldn’t be able to use this solution. Is there a way to speed it up considerably (ie ~30 sec max)
The second module applies only to the bottom section of the P&L (starting row 334) and is the exact replica of the first module but attempts to ignore SL (L4:O4) as parameters as it is fixed in column I for value 145 (text format). Therefore SL in this module is treated like accounts and like column J “Code”
I’m having problems running this module. Not sure why. Would you be so kind as to look into the code?
I am attaching the files to
Module 1 code:
Sub AddEmUp()
Dim MyTable As Range, MyAccts As Range, MyDates As Range, MyParms As Range, MyParmCols As Variant
Dim MyData As Variant, MyParmData As Variant, MyFilter As Object
Dim i As Long, j As Long, k As Long, d1 As String, acct As Variant, acc As Long, mdate As Variant
' Define parameters
Set MyTable = Sheets("Raw Data").Range("A1:M1") ' Define top row of the data table, the macro figures -
' out the bottom row based on the last non-empty cell in A
Set MyAccts = Sheets("Sheet2").Range("G14:G333") ' This should be the column where the accounts are -
' set the rows to first row with an account to the -
' last row with an account, empty cells will be ignored
Set MyDates = Sheets("Sheet2").Range("M12:X12, AF12:AQ12, AY12:BJ12, BR12:CC12") ' Set this to the cells with the dates, if there are gaps, -
' define the ranges as shown. The "ACTUALS" or "BUDGET" -
' row is assumed to be above this row
Set MyParms = Sheets("Sheet2").Range("L2:O7") ' The parameters - can be an actual parameter or a "*" to mean -
' match anything - no other wildcards are supported
MyParmCols = Array(1, 2, 3, 4, 5, 6) ' The columns that the parameters relate to - in this example, -
' the parameters on row 2 match column 1 (A) on the "Raw Data" -
' sheet, row 3 matches column 2, row 4 matches column 3, row 5 -
' matches nothing (0), etc.
' Read the "Raw Data"
MyData = MyTable.Resize(MyTable.Resize(1, 1).Offset(Rows.Count - 1).End(xlUp).Row).Value
' Read the parms
MyParmData = MyParms.Value
' Create a dictionary to put the totals in
Set MyFilter = CreateObject("Scripting.Dictionary")
' Read through the raw data, selecting the rows that match the parameters
For i = 1 To UBound(MyData)
For j = 1 To MyParms.Rows.Count
If MyParmCols(j - 1) = 0 Then GoTo NextJ:
For k = 1 To 4
If MyData(i, MyParmCols(j - 1)) = MyParms(j, k) Or MyParms(j, k) = "*" Then GoTo NextJ:
Next k
GoTo NextI:
NextJ:
Next j
' Found a match on all parameters, create a key with the acct, month, year, and type,then add up the total
d1 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12)) & "|" & CLng(MyData(i, 13))
MyFilter(d1) = MyFilter(d1) + MyData(i, 11)
NextI:
Next i
' All totals found, now read through all the accounts/dates on the output sheet and place the totals
Application.ScreenUpdating = False
For Each acct In MyAccts
acc = acct.Value
If acc <> 0 Then ' ignore empty cells in the Accounts column
For Each mdate In MyDates
' Make a key with the account, month, year, and type, and read the total from the dictionary
d1 = CLng(acct) & "|" & Month(mdate) & "|" & Year(mdate) & "|" & LCase(CStr(mdate.Offset(-1))) & "|" & acct.Offset(, 3)
Cells(acct.Row, mdate.Column) = MyFilter(d1)
Next mdate
End If
Next acct
Application.ScreenUpdating = True
End Sub
Module 2 code:
Sub AddEmUp()
Dim MyTable As Range, MyAccts As Range, MyDates As Range, MyParms As Range, MyParmCols As Variant
Dim MyData As Variant, MyParmData As Variant, MyFilter As Object
Dim i As Long, j As Long, k As Long, d1 As String, acct As Variant, acc As Long, mdate As Variant
' Define parameters
Set MyTable = Sheets("Raw Data").Range("A1:M1") ' Define top row of the data table, the macro figures -
' out the bottom row based on the last non-empty cell in A
Set MyAccts = Sheets("Sheet2").Range("G336:G570") ' This should be the column where the accounts are -
' set the rows to first row with an account to the -
' last row with an account, empty cells will be ignored
Set MyDates = Sheets("Sheet2").Range("M12:X12, AF12:AQ12, AY12:BJ12, BR12:CC12") ' Set this to the cells with the dates, if there are gaps, -
' define the ranges as shown. The "ACTUALS" or "BUDGET" -
' row is assumed to be above this row
Set MyParms = Sheets("Sheet2").Range("L2:O7") ' The parameters - can be an actual parameter or a "*" to mean -
' match anything - no other wildcards are supported
MyParmCols = Array(1, 2, 0, 4, 5, 6) ' The columns that the parameters relate to - in this example, -
' the parameters on row 2 match column 1 (A) on the "Raw Data" -
' sheet, row 3 matches column 2, row 4 matches column 3, row 5 -
' matches nothing (0), etc.
' Read the "Raw Data"
MyData = MyTable.Resize(MyTable.Resize(1, 1).Offset(Rows.Count - 1).End(xlUp).Row).Value
' Read the parms
MyParmData = MyParms.Value
' Create a dictionary to put the totals in
Set MyFilter = CreateObject("Scripting.Dictionary")
' Read through the raw data, selecting the rows that match the parameters
For i = 1 To UBound(MyData)
For j = 1 To MyParms.Rows.Count
If MyParmCols(j - 1) = 0 Then GoTo NextJ:
For k = 1 To 4
If MyData(i, MyParmCols(j - 1)) = MyParms(j, k) Or MyParms(j, k) = "*" Then GoTo NextJ:
Next k
GoTo NextI:
NextJ:
Next j
' Found a match on all parameters, create a key with the acct, month, year, and type,then add up the total
d1 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12)) & "|" & CLng(MyData(i, 13)) & "|" & CLng(MyData(i, 3))
MyFilter(d1) = MyFilter(d1) + MyData(i, 11)
NextI:
Next i
' All totals found, now read through all the accounts/dates on the output sheet and place the totals
Application.ScreenUpdating = False
For Each acct In MyAccts
acc = acct.Value
If acc <> 0 Then ' ignore empty cells in the Accounts column
For Each mdate In MyDates
' Make a key with the account, month, year, and type, and read the total from the dictionary
d1 = CLng(acct) & "|" & Month(mdate) & "|" & Year(mdate) & "|" & LCase(CStr(mdate.Offset(-1))) & "|" & acct.Offset(, 3) & "|" & acct.Offset(, 2)
Cells(acct.Row, mdate.Column) = MyFilter(d1)
Next mdate
End If
Next acct
Application.ScreenUpdating = True
End Sub
Many thanks
https://www.dropbox.com/s/hi3wrsz861h1lwc/2018 NEW FORECAST MODEL v16c DB.xlsb?dl=0