VBA multiple sumifs and countifs groupings in large range using loop

Question

I am looking for assistance with the code at the last section referenced as "Logic to calculate allocation". I'm looking to conduct various SumIfs divided by CountIfs 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 SumIfs and CountIfs.

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

• Raystafarian: If you step through it where does it stall
• fonzy16: The latency issue is in the last For Each loop under the section "Logic to calculate allocation". It is going through each cell to execute the formula of the multiple sumifs / countifs. The range GLAllocRg is about 30k rows and 20+columns.
• Comintern: What does a typical data set look like? The structure of the final loop makes me think that a OOP approach would be much, much faster. Right now the 4 SumIfs and 4 CountIfs add up to basically 8 full table scans each time through the loop.

Answer 1

Couple of notes:

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")

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.

---

All of these are interacting with the sheet rather than an array -

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
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
For Each cell In EntriesWk.Range(EntriesWk.Cells(TranshRow, 1), EntriesWk.Cells(TranshRow, TypeCol))
For Each c In GLAllocRg

Which is basically the equivalent of using .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

Instead, read the ranges into arrays and work with those arrays in VBA and then write them back.

---

Each of your loops is hitting the sheet, what, tens of thousand times? Combine the loops as well instead of running them one after another. Or, better yet, use a select case in the loop.

Select Case cell
 Case cell = "PIR Location"
 'do stuff
 Case cell = "PIR Value"
 'do stuff
 Case cell = "PIR Location2"
 'do stuff
 Else: 'default stuff
End Select

---

Variable names - give your variables meaningful names. Right now I have no idea what a TransAmtCol should be by just looking at it.

---

Not sure what your data looks like, but is this how you identify the headers?

fCol = MainWk.Cells.Find("Property", lookat:=xlWhole).Column
hrow = MainWk.Cells.Find("Property", lookat:=xlWhole).Row

If so, do you need both the row and column? Additionally, is this the way you find your entire data range?

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

If so, I would do something like this instead:

Dim lastRow As Long
Dim lastColumn As Long
lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
lastColumn = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataArray As Variant
dataArray = Sheet1.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Value

Now all of your data is in a 2d array and you're basically indexing the array for columns?

For i = LBound(dataArray) To UBound(dataArray)
 If dataArray(1, i) = "Property" Then propertyColumn = i
Next

But, I'm not sure if you'll need those header positions or not given you're assigning them right back to a range? I think keeping an index of the headers will still probably be a good idea, so when you search for a value you can limit it to (i, propertyColumn). And you won't need a reference to the column given you know the size of your array (1 to lastRow, 1 to lastColumn)

Set PropIDRg = MainWk.Range(MainWk.Cells(fRow, PropIDCol), MainWk.Cells(lRow, PropIDCol))

Now just becomes a reference to propertyColumn in the dataArray and you can use Lbound andUbound or lastRow and lastColumn for iteration. You can make four arrays:

Dim mainData as Variant
Dim entryData as Variant
Dim entityData as Variant
Dim entityLocation as Variant

You can reuse variables so you'd end up

Dim lastRow As Long
Dim lastColumn As Long
Dim mainData As Variant
Dim entryData As Variant
Dim entityData As Variant
Dim entityLocation As Variant
lastRow = mainDataSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastColumn = mainDataSheet.Cells(1, Columns.Count).End(xlToLeft).Column
mainData = mainDataSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))
lastRow = entrySheet.Cells(Rows.Count, 1).End(xlUp).Row
lastColumn = entrySheet.Cells(1, Columns.Count).End(xlToLeft).Column
entryData = entrySheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))