The vba code below matches numbers in one column from sheet 2 to numbers found in sheet 1 to replace those numbers with the ones it matches from sheet 2. I am not an expert, but I am trying to make this vba code run faster. I am having it reference around 40,000 lines. How can I make this faster? Right now it won't run at all and just keeps running. (I am getting a spinning apple wheel.) With smaller sets of data it works. Greatly appreciate any help!
Code:
Sub prep_Replace()
Dim wk As Worksheet, ws As Worksheet, c As Range, fn As Range, fAdr As String, rpl As String, frowT As Long
Dim i As Long, j As Long
Set wk = Sheet1
Set ws = Sheet2
frowT = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Range("B2:B" & frowT).AdvancedFilter xlFilterCopy, , ws.Cells(frowT + 2, 1), True
Set tmp = ws.Cells(frowT + 2, 1).Resize(ws.Cells(frowT + 2, 1).CurrentRegion.Rows.Count - 1)
For Each c In tmp
Set fn = ws.Range("B:B").Find(c.Value, , xlValues, xlWhole)
If Not fn Is Nothing Then
fAdr = fn.Address
Do
rpl = rpl & ", " & fn.Offset(, -1).Value
Set fn = ws.Range("B:B").FindNext(fn)
Loop While fAdr <> fn.Address
End If
FIND_AND_REPLACE rpl, c.Value
rpl = ""
Set fn = Nothing
Next
tmp.ClearContents
Set tmp = Nothing
For i = 2 To frow
wk.Range("AR" & i) = ""
For j = 39 To 43
If Trim(wk.Cells(i, j)) <> "" Then
wk.Range("AR" & i) = wk.Range("AR" & i) & "," & Trim(wk.Cells(i, j))
End If
Next j
If Trim(wk.Range("AR" & i)) <> "" Then
wk.Range("AR" & i) = Right(wk.Range("AR" & i), Len(wk.Range("AR" & i)) - 1)
End If
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Sub FIND_AND_REPLACE(ByRef rpl As String, ByRef mfr As String)
On Error Resume Next
Application.ScreenUpdating = False
Dim toFind As String, toReplace As String, rng As Range, cel As Range, i As Long, frow As Long, _
frowT As Long, wk As Worksheet, ws As Worksheet, j As Long, fn As Range
Set wk = Sheet1: Set ws = Sheet2
frow = wk.Range("AM" & Rows.Count).End(xlUp).Row
frowT = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = wk.Range("AM2:AQ" & frow)
toFind = mfr
toReplace = rpl
Set fn = rng.Find(toFind, , xlValues, xlWhole)
If Not fn Is Nothing Then
fn = rpl
fn.Characters(1, 1).Delete
End If
End Sub
Last edited:
