Hi Amy,

Let me know if this is any better / faster:

Code:

Option Explicit
Sub Macro2()
Dim sFind As String, sAddr As String
Dim rRng As Range, rCl As Range, rFnd As Range
Dim rngMyCell As Range
Dim dblAmt As Double
Dim blnMatch As Boolean
Dim xlnCalcMethod As XlCalculation
With Application
.ScreenUpdating = False
xlnCalcMethod = .Calculation
.Calculation = xlCalculationManual
End With
For Each rngMyCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Len(rngMyCell.Offset(0, 2)) = 0 Then
sFind = CStr(rngMyCell)
dblAmt = Val(rngMyCell.Offset(0, 1))
blnMatch = False
'Adapted from Trebor76 and royUK code from here: _
https://www.ozgrid.com/forum/forum/help-forums/excel-general/116879-findall-in-vba
Set rRng = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
With rRng
Set rCl = .Find(sFind, LookIn:=xlValues)
If Not rCl Is Nothing Then
sAddr = rCl.Address
If Val(rCl.Offset(0, 1)) = dblAmt * -1 Then
rngMyCell.Offset(0, 2).Value = True
rCl.Offset(0, 2).Value = True
blnMatch = True
End If
If blnMatch = False Then
Do
If rFnd Is Nothing Then
Set rFnd = rCl
End If
Set rCl = .FindNext(rCl)
If Val(rCl.Offset(0, 1)) = dblAmt * -1 Then
rngMyCell.Offset(0, 2).Value = True
rCl.Offset(0, 2).Value = True
blnMatch = True
Exit Do
End If
Loop While Not rCl Is Nothing And rCl.Address <> sAddr
End If
If blnMatch = False Then
rngMyCell.Offset(0, 2).Value = False
End If
End If
End With
End If
Next rngMyCell
With Application
.ScreenUpdating = False
.Calculation = xlnCalcMethod
End With
MsgBox "Numbers (Col B) have been matched to Policy Numbers (Col. A).", vbInformation
End Sub

Robert

## Like this thread? Share it with others