Nesting For loops in VBA - excel

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