Improve speed of For each loop

[ovikstrom]

Hi,

I am currently working on the below a macro that loops through a range and inserts a formula depending on the value of a cell outside of the range. I am running about 5 of these in the same macro and the work fine, but the time to execute is quite long (1.5min). I am looking to run this frequently throughout the day and I was wondering if there are any suggestions on how I can speed it up?

Sub improvedmacro()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
 
For Each c In Worksheets("Fund Data").Range("J4:J195").Cells

If c.Offset(0, -6).Value = "Lux" Then
    c.FormulaArray = "=INDEX('Lux Data'!C[-9]:C[-1],MATCH(1,('Lux Data'!C[-9]=RC[-5])*('Lux Data'!C[-7]=RC[-4])*('Lux Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)"
ElseIf c.Offset(0, -6).Value = "Ire" Then
    c.FormulaArray = "=INDEX('Irish Data'!C[-9]:C[-1],MATCH(1,('Irish Data'!C[-9]=RC[-5])*('Irish Data'!C[-7]=RC[-4])*('Irish Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)"
ElseIf c.Offset(0, -6).Value = "CH" Then
            c.FormulaR1C1 = "=VLOOKUP(RC3,'Swiss NAV'!R1C2:R23C21,12,FALSE)"
End If
Next
End Sub

I appreciate any ideas you might have.



Many thanks,
OVikstrom

 

[tonyyy]

OVikstrom,

Welcome to the Board.

Rather than loop through each cell, another approach would be to filter the range then fill the visible cells...

Sub FilterFill()
'Assumes headers in Row 3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim ws1 As Worksheet
Dim arr1() As Variant, arr2() As Variant
Dim i As Long
Set ws1 = Sheets("Fund Data")
arr1 = Array("Lux", "Ire", "CH")
arr2 = Array( _
        "=INDEX('Lux Data'!C[-9]:C[-1],MATCH(1,('Lux Data'!C[-9]=RC[-5])*('Lux Data'!C[-7]=RC[-4])*('Lux Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)", _
        "=INDEX('Irish Data'!C[-9]:C[-1],MATCH(1,('Irish Data'!C[-9]=RC[-5])*('Irish Data'!C[-7]=RC[-4])*('Irish Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)", _
        "=VLOOKUP(RC3,'Swiss NAV'!R1C2:R23C21,12,FALSE)")

For i = 0 To UBound(arr1)
    If ws1.AutoFilterMode = True Then ws1.AutoFilterMode = False
    With ws1.Range(Cells(3, 4), Cells(195, 10))
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:=arr1(i)
        ws1.Range(Cells(4, 10), Cells(195, 10)).SpecialCells(xlCellTypeVisible).Value = arr2(i)
    End With
Next i
ws1.AutoFilterMode = False
End Sub

Cheers,

tonyyy

 

[ovikstrom]

Hi Tonyyy,

Thank you very much for the welcome and the help on the macro. This approach is lightning speed fast, it works well. However, for the Index and Match formulas I get a #N/A in the cell even though the formula is correct. I am guessing this is because I need to use "FormulaArray" rather than "Array". But when I try to change arr2 = FormulaArray ( .....) I get a "Sub or function not defined" error. Do you know a way around this?

Many thanks again,
ovikstrom

 

[tonyyy]

Sub FilterFill()
'Assumes headers in Row 3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim ws1 As Worksheet
Dim arr1() As Variant, arr2() As Variant
Dim i As Long

Set ws1 = Sheets("Fund Data")
arr1 = Array("Lux", "Ire", "CH")
arr2 = Array( _
        "=INDEX('Lux Data'!C[-9]:C[-1],MATCH(1,('Lux Data'!C[-9]=RC[-5])*('Lux Data'!C[-7]=RC[-4])*('Lux Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)", _
        "=INDEX('Irish Data'!C[-9]:C[-1],MATCH(1,('Irish Data'!C[-9]=RC[-5])*('Irish Data'!C[-7]=RC[-4])*('Irish Data'!C[-2]=""NET SHARES OUTSTANDING""),0),9)", _
        "=VLOOKUP(RC3,'Swiss NAV'!R1C2:R23C21,12,FALSE)")

For i = 0 To UBound(arr1)
    If ws1.AutoFilterMode = True Then ws1.AutoFilterMode = False
    With ws1.Range(ws1.Cells(3, 4), ws1.Cells(195, 10))
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:=arr1(i)
        ws1.Range(Cells(4, 10), Cells(195, 10)).SpecialCells(xlCellTypeVisible).[COLOR=#ff0000]Formula [/COLOR]= arr2(i)
'        ws1.Range(ws1.Cells(4, 10), ws1.Cells(195, 10)).SpecialCells(xlCellTypeVisible).FormulaArray = arr2(i)
    End With
Next i
ws1.AutoFilterMode = False
[COLOR=#ff0000]ws1.Range(Cells(4, 10), Cells(195, 10)).FormulaArray = ws1.Range(Cells(4, 10), Cells(195, 10)).Formula[/COLOR]
End Sub

So... I tried first to use the line that's commented out, thinking that a Range.FormulaArray construct would work. Unfortunately, .FormulaArray doesn't like SpecialCells - at least I can't get it to work - so I opted for the solution in red. Sadly this is much slower, but may be incrementally faster than looping.

 

[ovikstrom]

Tonyyy, thanks for the help. Unfortunately that solution was pretty much the same speed as the original one. However, I was able to swap the INDEX & MATCH formula to a SUMIFS which does not require the .FormulaArray, due to the fact that all combinations are unique it seems to work well.

Sub FilterFill()
'Assumes headers in Row 3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim ws1 As Worksheet
Dim arr1() As Variant, arr2() As Variant
Dim i As Long
Set ws1 = Sheets("Fund Data")
arr1 = Array("Lux", "Ire", "CH")
arr2 = Array( _
        "=SUMIFS('Lux Data'!C[-2],'Lux Data'!C[-10],INDIRECT(""RC[-6]"",FALSE),'Lux Data'!C[-8],INDIRECT(""RC[-5]"",FALSE),'Lux Data'!C[-3],""NET SHARES OUTSTANDING"")", _
        "=SUMIFS('Irish Data'!C[-2],'Irish Data'!C[-10],INDIRECT(""RC[-6]"",FALSE),'Irish Data'!C[-8],INDIRECT(""RC[-5]"",FALSE),'Irish Data'!C[-3],""NET SHARES OUTSTANDING"")", _
        "=VLOOKUP(RC3,'Swiss NAV'!R1C2:R23C21,12,FALSE)")
For i = 0 To UBound(arr1)
    If ws1.AutoFilterMode = True Then ws1.AutoFilterMode = False
    With ws1.Range(Cells(3, 4), Cells(195, 11))
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:=arr1(i)
        ws1.Range(Cells(4, 11), Cells(195, 11)).SpecialCells(xlCellTypeVisible).Value = arr2(i)
       ' ws1.Range(Cells(4, 10), Cells(195, 10)).SpecialCells(xlCellTypeVisible).Value = ws1.Range(Cells(4, 10), Cells(195, 10)).SpecialCells(xlCellTypeVisible).FormulaArray
    End With
Next i
ws1.AutoFilterMode = False
End Sub

 

[tonyyy]

Glad you found a solution, ovikstrom. Thanks for the feedback.