Nesting For loops in VBA

Question

Sub adress()
Dim s As Long
Dim h As Long
Dim n As Long
Dim i As Long

s = 1
n = 1
h = 1

For n = 1 To 1800

    For i = 1 To 2000
        If ActiveSheet.Cells(h + 1, 13) = ActiveSheet.Cells(s + 1, 32) Then
            ActiveSheet.Cells(h + 1, 48) = ActiveSheet.Cells(s + 1, 36)
            ActiveSheet.Cells(h + 1, 51) = ActiveSheet.Cells(s + 1, 37)
        End If
        s = s + 1
    
    Next i
    h = h + 1

    i = 1

Next n
End Sub

This code is written to grab a value in a column of an excel spread sheet, then go to the next column and search the whole column for a matching value. Once that is found it will print the value that is in a cell in the same row of the value in the second column it found, into a cell in the same row as the original value it was trying to match.

While the inner loop works and my code will do the correct process when ran, it only does it for one value in the first column. I have tried using ranges in the For Loops, I have tried do while loops and do until loops. If i manually change the value of "h" and run the code it will progress down the column and print the correct information but i cannot get "h" to update on its own.

Answer 1

Nested For Next Loops

• Although Exit For and turning off the two application settings are used, the first procedure still takes 45 seconds on my machine (without the 'improvements' it might take half an hour).
• In the second code the inner loop is replaced with Application.Match and the operations are performed using arrays. It takes less than a second.

The Code

Option Explicit

Sub loopSlow()
    Dim i As Long
    Dim k As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With ActiveSheet
        For i = 2 To 1801
            For k = 2 To 2001
                If .Cells(i, 13).Value = .Cells(k, 32).Value Then
                    .Cells(i, 48).Value = .Cells(k, 36).Value
                    .Cells(i, 51).Value = .Cells(k, 37).Value
                    Exit For
                End If
            Next k
        Next i
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


Sub loopFast()
    
    ' Source
    Const sName As String = "Sheet2"
    Const sColsList As String = "AF,AJ,AK"
    Const sFirstRow As Long = 2
    ' Destination (Lookup)
    Const dName As String = "Sheet2"
    Const dColsList As String = "M,AV,AY"
    Const dFirstRow As Long = 2
    
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Declare variables.
    Dim ws As Worksheet
    Dim rg As Range
    Dim Cols() As String
    Dim cUpper As Long
    Dim cOffset As Long
    Dim n As Long
    
    ' Write values from Source Columns to arrays of Data Array.
    Cols = Split(sColsList, ",")
    cUpper = UBound(Cols)
    Set ws = wb.Worksheets(sName)
    Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
    Set rg = ws.Range(ws.Cells(sFirstRow, Cols(0)), rg)
    Dim Data As Variant: ReDim Data(0 To cUpper)
    For n = 0 To cUpper
        cOffset = ws.Columns(Cols(n)).Column - rg.Column
        Data(n) = rg.Offset(, cOffset).Value
    Next n
    
    ' Write values from Lookup Column to Lookup Array of Result Array.
    Cols = Split(dColsList, ",")
    Set ws = wb.Worksheets(dName)
    Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
    Set rg = ws.Range(ws.Cells(dFirstRow, Cols(0)), rg)
    Dim Result As Variant: ReDim Result(0 To cUpper)
    Result(0) = rg.Value
    
    ' Define the (remaining) Write Arrays of Result Array.
    Dim ResultNew As Variant: ReDim ResultNew(1 To UBound(Result(0)), 1 To 1)
    For n = 1 To cUpper
        Result(n) = ResultNew
    Next n
    
    ' Write values from Data Array to Write Arrays of Result Array.
    Dim cIndex As Variant
    Dim i As Long
    For i = 1 To UBound(Result(0))
        cIndex = Application.Match(Result(0)(i, 1), Data(0), 0)
        If IsNumeric(cIndex) Then
            For n = 1 To cUpper
                Result(n)(i, 1) = Data(n)(cIndex, 1)
            Next n
        End If
    Next i
    
    ' Write values from Write Arrays of Result Array to Destination Columns.
    For n = 1 To cUpper
        cOffset = ws.Columns(Cols(n)).Column - rg.Column
        rg.Offset(, cOffset).Value = Result(n)
    Next n
    
End Sub