I am looking for assistance with the code at the last section referenced as "Logic to calculate allocation". I'm looking to conduct various SumIf
s divided by CountIf
s for a range cells that span about 30k rows and over 20 columns. I've tested it for just one column and it provided the results I expected but the time was a little less than reasonable.
I've modified the VBA to run through all the cells in each column of the range but I have to shut it down since it has gone past 10 minutes with out an output. I have read different solutions with regards to using arrays but that is something I have not learned and am having difficulty applying the concept of some of the solutions posted to this scenario.
I'm looking for improvements in this part of the logic to help with the efficiency and time of the output whether it be using an alternative in place of the for each loop and/or another option to conduct the SumIf
s and CountIf
s.
Sub Alloc_Entity()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'---Timer----
Dim StartTime As Double
Dim Seconds As Double
StartTime = Timer
'---Worksheet dimensions-----
Dim MainWk As Worksheet
Dim EntriesWk As Worksheet
Dim EntMapxEntWk As Worksheet
Dim EntMapxLocWk As Worksheet
Set MainWk = Sheets("Main Allocation")
Set EntriesWk = Sheets("Entity Entries")
Set EntMapxEntWk = Sheets("Entity Mapping by GL entity cod")
Set EntMapxLocWk = Sheets("Entity Mapping by Location")
'-----variables for Main Wk-------
Dim hrow As Long, GLrow As Long, fRow As Long, lRow As Long, fCol As Long, lCol As Long, fGLCol As Long
Dim OwnedCol As Long, StableCol As Long, StateCol As Long, MarketCol As Long, PMCol As Long, AcqCoCol As Long, CompanyCol As Long, TRSCol As Long
Dim PropIDCol As Long, PropUnitIDCol As Long
fCol = MainWk.Cells.Find("Property", lookat:=xlWhole).Column
hrow = MainWk.Cells.Find("Property", lookat:=xlWhole).Row
GLrow = hrow - 1
fRow = hrow + 1
lCol = MainWk.Cells(hrow, Columns.Count).End(xlToLeft).Column
fGLCol = MainWk.Rows(GLrow).Find("-", lookat:=xlPart).Column
lRow = MainWk.Cells(Rows.Count, fCol).End(xlUp).Row
OwnedCol = MainWk.Cells.Find("Total Owned", lookat:=xlWhole).Column
StableCol = MainWk.Cells.Find("Total Stable", lookat:=xlWhole).Column
StateCol = MainWk.Cells.Find("State", lookat:=xlWhole).Column
MarketCol = MainWk.Cells.Find("Market", lookat:=xlWhole).Column
PMCol = MainWk.Cells.Find("Property Manager", lookat:=xlWhole).Column
AcqCoCol = MainWk.Cells.Find("Acquisition Company", lookat:=xlWhole).Column
CompanyCol = MainWk.Cells.Find("Company", lookat:=xlWhole).Column
TRSCol = MainWk.Cells.Find("Transferred to TRS Deed", lookat:=xlWhole).Column
PropIDCol = MainWk.Cells.Find("Property", lookat:=xlWhole).Column
PropUnitIDCol = MainWk.Cells.Find("Property Unit ID", lookat:=xlWhole).Column
'MsgBox (OwnedCol & " " & StableCol & " " & StateCol & " " & MarketCol & " " & PMCol & " " & AcqCoCol & " " & CompanyCol & " " & TRSCol)
'----Ranges for Main Wk-------
Dim PropIDRg As Range, PropUnitIDRg As Range, OwnedRg As Range, StableRg As Range, StateRg As Range
Dim MarketRg As Range, PMRg As Range, AcqCoRg As Range, CompanyRg As Range, TRSRg As Range
Set PropIDRg = MainWk.Range(MainWk.Cells(fRow, PropIDCol), MainWk.Cells(lRow, PropIDCol))
Set PropUnitIDRg = MainWk.Range(MainWk.Cells(fRow, PropUnitIDCol), MainWk.Cells(lRow, PropUnitIDCol))
Set OwnedRg = MainWk.Range(MainWk.Cells(fRow, OwnedCol), MainWk.Cells(lRow, OwnedCol))
Set StableRg = MainWk.Range(MainWk.Cells(fRow, StableCol), MainWk.Cells(lRow, StableCol))
Set StateRg = MainWk.Range(MainWk.Cells(fRow, StateCol), MainWk.Cells(lRow, StateCol))
Set MarketRg = MainWk.Range(MainWk.Cells(fRow, MarketCol), MainWk.Cells(lRow, MarketCol))
Set PMRg = MainWk.Range(MainWk.Cells(fRow, PMCol), MainWk.Cells(lRow, PMCol))
Set AcqCoRg = MainWk.Range(MainWk.Cells(fRow, AcqCoCol), MainWk.Cells(lRow, AcqCoCol))
Set CompanyRg = MainWk.Range(MainWk.Cells(fRow, CompanyCol), MainWk.Cells(lRow, CompanyCol))
Set TRSRg = MainWk.Range(MainWk.Cells(fRow, TRSCol), MainWk.Cells(lRow, TRSCol))
'-----Variables for Entity Entries------
Dim TranshRow As Long, TransfRow As Long, TranslRow As Long, TransGLCol As Long, TransAmtCol As Long
Dim TypeCol As Long, EntPIRLocCol As Long, EntPIRValueCol As Long, EntPIRLoc2Col As Long, EntPIRValue2Col As Long
Dim LocPIRLocCol As Long, LocPIRValueCol As Long, MultipleFiltersCol As Long
TranshRow = EntriesWk.Cells.Find("Control", lookat:=xlWhole).Row
TransfRow = TranshRow + 1
TranslRow = EntriesWk.Cells(Rows.Count, 1).End(xlUp).Row
TransGLCol = EntriesWk.Cells.Find("GL Acct", lookat:=xlWhole).Column
TransAmtCol = EntriesWk.Cells.Find("Balance", lookat:=xlWhole).Column
TypeCol = EntriesWk.Cells.Find("Type", lookat:=xlWhole).Column
MultipleFiltersCol = EntriesWk.Cells.Find("Multiple Filters", lookat:=xlWhole).Column
Dim cell As Range
For Each cell In EntriesWk.Range(EntriesWk.Cells(TranshRow, 1), EntriesWk.Cells(TranshRow, TypeCol))
If cell = "PIR Location" Then
If cell.Offset(-1, 0) = "Entity" Then
EntPIRLocCol = cell.Column
Else
If cell.Offset(-1, 0) = "Location" Then
LocPIRLocCol = cell.Column
End If
End If
End If
Next
For Each cell In EntriesWk.Range(EntriesWk.Cells(TranshRow, 1), EntriesWk.Cells(TranshRow, TypeCol))
If cell = "PIR Value" Then
If cell.Offset(-1, 0) = "Entity" Then
EntPIRValueCol = cell.Column
Else
If cell.Offset(-1, 0) = "Location" Then
LocPIRValueCol = cell.Column
End If
End If
End If
Next
For Each cell In EntriesWk.Range(EntriesWk.Cells(TranshRow, 1), EntriesWk.Cells(TranshRow, TypeCol))
If cell = "PIR Location2" Then
EntPIRLoc2Col = cell.Column
Else
If cell = "PIR Value2" Then
EntPIRValue2Col = cell.Column
End If
End If
Next
'-----Ranges for Entity Entries------
Dim TypeRg As Range, EntPIRLocRg As Range, EntPIRValueRg As Range, EntPIRLoc2Rg As Range, EntPIRValue2Rg As Range
Dim LocPIRLocRg As Range, LocPIRValueRg As Range, MultipleFiltersRg As Range, TransGLRg As Range, AmtRg As Range
Set TypeRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, TypeCol), EntriesWk.Cells(TranslRow, TypeCol))
Set EntPIRLocRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, EntPIRLocCol), EntriesWk.Cells(TranslRow, EntPIRLocCol))
Set EntPIRValueRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, EntPIRValueCol), EntriesWk.Cells(TranslRow, EntPIRValueCol))
Set EntPIRLoc2Rg = EntriesWk.Range(EntriesWk.Cells(TransfRow, EntPIRLoc2Col), EntriesWk.Cells(TranslRow, EntPIRLoc2Col))
Set EntPIRValue2Rg = EntriesWk.Range(EntriesWk.Cells(TransfRow, EntPIRValue2Col), EntriesWk.Cells(TranslRow, EntPIRValue2Col))
Set LocPIRLocRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, LocPIRLocCol), EntriesWk.Cells(TranslRow, LocPIRLocCol))
Set LocPIRValueRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, LocPIRValueCol), EntriesWk.Cells(TranslRow, LocPIRValueCol))
Set MultipleFiltersRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, MultipleFiltersCol), EntriesWk.Cells(TranslRow, MultipleFiltersCol))
Set TransGLRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, TransGLCol), EntriesWk.Cells(TranslRow, TransGLCol))
Set AmtRg = EntriesWk.Range(EntriesWk.Cells(TransfRow, TransAmtCol), EntriesWk.Cells(TranslRow, TransAmtCol))
'-----Logic to calculate allocation---------
Dim GLcell As Range, GLAllocRg As Range, c As Range
'For Each GLcell In MainWk.Range(MainWk.Cells(GLrow, fGLCol), MainWk.Cells(GLrow, lCol))
'Set GLAllocRg = MainWk.Range(MainWk.Cells(fRow, GLcell.Column), MainWk.Cells(lRow, GLcell.Column))
Set GLAllocRg = MainWk.Range(MainWk.Cells(fRow, fGLCol), MainWk.Cells(lRow, lCol)) '------used for testing
For Each c In GLAllocRg
c = ((WorksheetFunction.SumIfs(AmtRg, TypeRg, "Entity", TransGLRg, MainWk.Cells(GLrow, c.Column).Value, EntPIRLocRg, "Acquisition Company", EntPIRValueRg, MainWk.Cells(c.Row, AcqCoCol).Value) / WorksheetFunction.CountIfs(AcqCoRg, MainWk.Cells(c.Row, AcqCoCol).Value))) _
+ (WorksheetFunction.SumIfs(AmtRg, TypeRg, "Entity", TransGLRg, MainWk.Cells(GLrow, c.Column).Value, EntPIRLocRg, "Property Manager", EntPIRValueRg, MainWk.Cells(c.Row, PMCol).Value) / WorksheetFunction.CountIfs(PMRg, MainWk.Cells(c.Row, PMCol).Value)) _
+ (WorksheetFunction.SumIfs(AmtRg, TypeRg, "Entity", TransGLRg, MainWk.Cells(GLrow, c.Column).Value, EntPIRLocRg, "Market", EntPIRValueRg, MainWk.Cells(c.Row, MarketCol).Value) / WorksheetFunction.CountIfs(MarketRg, MainWk.Cells(c.Row, MarketCol).Value)) _
+ (WorksheetFunction.SumIfs(AmtRg, TypeRg, "Entity", TransGLRg, MainWk.Cells(GLrow, c.Column).Value, EntPIRLocRg, "State", EntPIRValueRg, MainWk.Cells(c.Row, StateCol).Value) / WorksheetFunction.CountIfs(StateRg, MainWk.Cells(c.Row, StateCol).Value))
Next
'Next
Seconds = Round(Timer - StartTime, 2)
MsgBox (Seconds)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub