Loop Optimisation: merge two loops into one

Question

I wrote the two loops below:

Dim intLstRowA As Integer
Dim intLstRowB As Integer

intLstRowA = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
intLstRowB = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To intLstRowA
        Sheets(1).Cells(i, 22).Value2 = Sheets(1).Cells(i, 4).Value2 * Sheets(1).Cells(i, 5).Value2
        Sheets(1).Cells(i, 23).Value2 = Sheets(1).Cells(i, 4).Value2 * Sheets(1).Cells(i, 6).Value2
        Sheets(1).Cells(i, 24).Value2 = Sheets(1).Cells(i, 4).Value2 * Sheets(1).Cells(i, 9).Value2
        Sheets(1).Cells(i, 25).Value2 = Sheets(1).Cells(i, 4).Value2 * Sheets(1).Cells(i, 19).Value2
        Sheets(1).Cells(i, 26).Value2 = Sheets(1).Cells(i, 4).Value2 * Sheets(1).Cells(i, 20).Value2
Next i
For i = 2 To intLstRowB
        Sheets(2).Cells(i, 22).Value2 = Sheets(2).Cells(i, 4).Value2 * Sheets(2).Cells(i, 5).Value2
        Sheets(2).Cells(i, 23).Value2 = Sheets(2).Cells(i, 4).Value2 * Sheets(2).Cells(i, 6).Value2
        Sheets(2).Cells(i, 24).Value2 = Sheets(2).Cells(i, 4).Value2 * Sheets(2).Cells(i, 9).Value2
        Sheets(2).Cells(i, 25).Value2 = Sheets(2).Cells(i, 4).Value2 * Sheets(2).Cells(i, 19).Value2
        Sheets(2).Cells(i, 26).Value2 = Sheets(2).Cells(i, 4).Value2 * Sheets(2).Cells(i, 20).Value2
Next i

There is two loops because intLstRowA is different than intLstRowB (usually the difference is from 20 to 50), otherwise I would have added a "j" value (from 1 to 2) to loop between Sheets(1) and Sheets(2).

Any idea?

Answer 1

This is about as tight as I can get it.

Dim i As Long, v As Long, s As Long, vCOLs As Variant

vCOLs = Array(Array(22, 23, 24, 25, 26), Array(5, 6, 9, 19, 20))

For s = 1 To 2
    With Sheets(s)
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            For v = LBound(vCOLs(1)) To UBound(vCOLs(1))
                .Cells(i, vCOLs(0)(v)) = .Cells(i, 4).Value2 * .Cells(i, vCOLs(1)(v)).Value2
            Next v
        Next i
    End With
Next s

This works by putting both rank of a two dimensional array to work supplying the column index numbers for the source and target of the computation.

Will compile but not field tested against sample data.

Answer 2

You can do this with a second sub (to remove) the duplication, and with ranges to remove loops, ie:

Sub Recut()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lngLstRowA As Long
Dim lngLstRowB As Long

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

lngLstRowA = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lngLstRowB = ws2.Cells(Rows.Count, 1).End(xlUp).Row

Call Update(ws1, lngLstRowA)
Call Update(ws2, lngLstRowB)

End Sub

Sub Update(ws As Worksheet, lngRow As Long)

With ws
    Range(.Cells(2, 22), .Cells(lngRow, 22)).FormulaR1C1 = "=RC4*RC5"
    Range(.Cells(2, 23), .Cells(lngRow, 23)).FormulaR1C1 = "=RC4*RC6"
    Range(.Cells(2, 24), .Cells(lngRow, 24)).FormulaR1C1 = "=RC4*RC9"
    Range(.Cells(2, 25), .Cells(lngRow, 25)).FormulaR1C1 = "=RC4*RC19"
    Range(.Cells(2, 26), .Cells(lngRow, 26)).FormulaR1C1 = "=RC4*RC20"
    Range(.Cells(2, 22), .Cells(lngRow, 26)).Value = Range(.Cells(2, 22), .Cells(lngRow, 26)).Value
End With

End Sub