Speed Up Macro Extracting Rows from Data using Column to Match - vba

Question

I'm looking for a way to speed up this code as it takes my computer 20-30 minutes to run. It essentially runs through a list of column values in sheet "A" and if It matches a column value in sheet "B" it will pull the entire corresponding row to the sheet "Match".
Sub MatchSheets()
Dim lastRowAF As Integer
Dim lastRowL As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
Application.ScreenUpdating = False
lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRowAF
foundTrue = False
For j = 1 To lastRowL
If Sheets("FHA").Cells(i, 32).Value = Sheets("New Construction").Cells(j, 12).Value Then
foundTrue = True
Exit For
End If
Next j
If foundTrue Then
Sheets("FHA").Rows(i).Copy Destination:= _
Sheets("Match").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
Application.ScreenUpdating = True
End Sub

Answer 1

Collections are optimized for looking values. Using a combination of a Collection and Array is usually the best way to match two list. 20K Rows X 54 Columns (140K Values) took this code 10.87 seconds to copy over on a slow PC.
Sub NewMatchSheets()
Dim t As Double: t = Timer
Const NUM_FHA_COLUMNS As Long = 54, AF As Long = 32
Dim list As Object
Dim key As Variant, data() As Variant, results() As Variant
Dim c As Long, r As Long, count As Long
ReDim results(1 To 50000, 1 To 100)
Set list = CreateObject("System.Collections.ArrayList")
With ThisWorkbook.Worksheets("New Construction")
data = .Range("L1", .Cells(.Rows.count, "L").End(xlUp)).Value
For Each key In data
If key <> "" Then
If Not list.Contains(key) Then list.Add key
End If
Next
End With
With ThisWorkbook.Worksheets("FHA")
data = .Range(.Range("A1").Resize(1, NUM_FHA_COLUMNS), .Cells(.Rows.count, AF).End(xlUp)).Value
For r = 1 To UBound(data)
key = data(r, AF)
If list.Contains(key) Then
count = count + 1
For c = 1 To UBound(data, 2)
results(count, c) = data(r, c)
Next
End If
Next
End With
If count = 0 Then Exit Sub
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Match")
With .Cells(.Rows.count, "A").End(xlUp)
.Offset(1).Resize(count, NUM_FHA_COLUMNS).Value = results
End With
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Debug.Print Round(Timer - t, 2)
End Sub

Answer 2

use variant arrays:
Sub MatchSheets()
Dim lastRowAF As Long
Dim lastRowL As Long
Dim lastRowM As Long
Application.ScreenUpdating = False
lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row
Dim FHAArr As Variant
FHAArr = Sheets("FHA").Range(Sheets("FHA").Cells(1, 1), Sheets("FHA").Cells(lastRowAF, Columns.Count).End(xlToLeft)).Value
Dim NewConArr As Variant
NewConArr = Sheets("New Construction").Range(Sheets("New Construction").Cells(1, 12), Sheets("New Construction").Cells(lastRowL, 12)).Value
Dim outarr As Variant
ReDim outarr(1 To UBound(FHAArr, 1), 1 To UBound(FHAArr, 2))
Dim k As Long
k = 0
Dim l As Long
For i = 1 To lastRowAF
For j = 1 To lastRowL
If FHAArr(i, 32) = NewConArr(j, 1) Then
For l = 1 To UBound(FHAArr, 2)
k = k + 1
outarr(k, l) = FHAArr(i, l)
Next l
Exit For
End If
Next j
Next i
Sheets("Match").Cells(lastRowM + 1, 1).Resize(UBound(outarr, 1), UBound(outarr, 2)).Value = outarr
Application.ScreenUpdating = True
End Sub

Answer 3

FHA Worksheet: 2500 rows by 50 columnsNew Construction Worksheet: 500 rows by 1 column LMatch Worksheet: 450 transfers from FMA Elapsed time: 0.13 seconds
Get rid of all the nested loop and work with arrays.
Your narrative seemed to suggest that there might be multiple matches for any one value but your code only looks for a single match then Exit For. I'll work with the latter of the two scenarios.
Sub MatchSheets()
Dim i As Long, j As Long
Dim vFM As Variant, vNC As Variant
Debug.Print Timer
With Worksheets("New Construction")
vNC = .Range(.Cells(1, "L"), _
.Cells(.Rows.Count, "L").End(xlUp)).Value2
End With
With Worksheets("FHA")
vFM = .Range(.Cells(1, "A"), _
.Cells(.Rows.Count, _
.Cells(1, .Columns.Count).End(xlToLeft).Column).End(xlUp)).Value2
End With
ReDim vM(LBound(vFM, 2) To UBound(vFM, 2), 1 To 1)
For i = LBound(vFM, 1) To UBound(vFM, 1)
If Not IsError(Application.Match(vFM(i, 32), vNC, 0)) Then
For j = LBound(vFM, 2) To UBound(vFM, 2)
vM(j, UBound(vM, 2)) = vFM(i, j)
Next j
ReDim Preserve vM(LBound(vFM, 2) To UBound(vFM, 2), LBound(vM, 2) To UBound(vM, 2) + 1)
End If
Next i
With Worksheets("match")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(UBound(vM, 2), UBound(vM, 1)) = _
Application.Transpose(vM)
End With
Application.ScreenUpdating = True
Debug.Print Timer
End Sub

Answer 4

Try changing this line:
Sheets("FHA").Rows(i).Copy Destination:= _
Sheets("Match").Rows(lastRowM + 1)
For the following line:
Sheets("Match").Rows(lastRowM + 1).Value for Sheets("FHA").Rows(i).value
If you really need to shave milliseconds, you could also set: lastRowM to be:
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row + 1
And use:
Sheets("Match").Rows(lastRowM).Value for Sheets("FHA").Rows(i).value
Thus saving you an addition every time you go through that part of the code