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

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