Speed Up Finding Occurrences in Multiple Sheets via VBA

Question

with the below code I m finding how many times a contact has been reached. In order to do so, the formula is using a named range (Weeks) and search for the partner name across multiple sheets.

I am not using a simple formula because the file change depending on the person that is using the file so I am using VBA.

Although the below code works, this is a very slow and I am wondering if someone could help me in speeding it up or could suggest me other methods to get the same results.

Sub ContactCycle()

Dim WsMaster As Worksheet
Dim WsLastRow As Long
Dim MyContactCycleRange As Range, cell As Range

Set WsMaster = ThisWorkbook.Worksheets("Master")
WsLastRow = WsMaster.Range("A" & Rows.Count).End(xlUp).Row

Set MyContactCycleRange = WsMaster.Range("AB5:AB" & WsLastRow)
Application.EnableEvents = False
For Each cell In MyContactCycleRange
cell.Formula = "=IF(SUMPRODUCT(COUNTIF(INDIRECT(""'""&Weeks&""'!""&""$A$6:$A$45""),$B5))>0,1,0)"
Next cell
Application.EnableEvents = True
End Sub

Thank you

score 0 · Answer 1 · answered Sep 23 '21 at 12:23

I managed to make it faster with outputrange as per below:

Sub ContactCycle()
Dim WsMaster As Worksheet
Dim WsLastRow As Long
Dim OutputRange As Range
Dim tmpCalc As XlCalculation: tmpCalc = Application.Calculation 'Save setting
Const OutputColumn As Long = 28 ' "AB"

Set WsMaster = ThisWorkbook.Worksheets("Master")
Set MyContactCycleRange = WsMaster.Range("AB5:AB" & WsLastRow)
Set OutputRange = WsMaster.Range(WsMaster.Cells(5, OutputColumn), WsMaster.Cells(WsLastRow, OutputColumn))


Application.Calculation = xlCalculationManual 'Makes things slightly faster
     With OutputRange
        .Formula = "=IF(SUMPRODUCT(COUNTIF(INDIRECT(""'""&Weeks&""'!""&""$A$6:$A$45""),$B5))>0,1,0)"  'This will fill down automatically
        .Calculate 'Needed because Calculation is currently manual
        .Value = .Value 'Convert the formulae into flat values
        .HorizontalAlignment = xlCenter
        .Font.Color = RGB(0, 32, 96)
        .Font.Bold = True
        .Font.Size = 9
        .Font.Name = "Calibri"
        .NumberFormat = "0"
    End With
        Application.Calculation = tmpCalc 'Restore setting saved earlier
End Sub

Speed Up Finding Occurrences in Multiple Sheets via VBA

1 Answers1