Code to Match not finding all the matches

[Tim Hanson]

My matching code is "not" finding all the matches and finding matches that do not exsits

I think the problem is here

PostBackWS.Range(fCell.Address).Offset(0, 0).Interior.Color = RGB(255, 255, 0)

fCell.Address

is getting out off sequence

I know there are lots of ways to match, but I was hoping someone can help get this code working

Also I mostly match on text but I have numbers here because it was easy to generate data for testing

I have uploaded a file with data showing the problem

Thanks

Sub sColorMatch()
Dim PostBackWS As Worksheet
Dim FindRng As Range, ReplaceRng As Range, fCell As Range, rCell As Range
Dim lRowFR As Long, lRowRR As Long

Dim t As Date
    t = Now()
   
        With ThisWorkbook.Sheets("X")
            lRowFR = .Range("A" & .Rows.Count).End(xlUp).Row
            Set FindRng = .Range("A2:A" & lRowFR)
        End With
       

        With ThisWorkbook.Sheets("Y")
            lRowRR = .Range("A" & .Rows.Count).End(xlUp).Row
            Set ReplaceRng = .Range("A2:A" & lRowRR)
        End With
   
    Set PostBackWS = ThisWorkbook.Sheets("Y")
   
    For Each fCell In FindRng
      If DoesMatchExists(fCell, ReplaceRng) = True Then
        'Set Interior Color for Matches
          PostBackWS.Range(fCell.Address).Offset(0, 0).Interior.Color = RGB(255, 255, 0)
         
        End If
    Next fCell
     
MsgBox Format(Now() - t, "hh:mm:ss")
     
End Sub

Function DoesMatchExists(ByVal searchName As String, nameRange As Range) As Boolean
    Dim i As Long
    Dim j As Long
    Dim v As Variant
    v = nameRange.Value
    DoesMatchExists = False
    For i = 1 To UBound(v, 1)
        For j = 1 To UBound(v, 2)
            If v(i, j) = searchName Then
                DoesMatchExists = True
                Exit Function
            End If
        Next j
    Next i
End Function

 

[Nebu]

Hi:

I am not sure why you have elaborate functions and subroutines to color the matching cells. I have used the following code to achieve the same.

Sub test()

Dim i As Long, j As Long, cnt As Long, lValue As Long

i = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
j = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row

For cnt = 2 To j
    On Error Resume Next
    lValue = WorksheetFunction.VLookup(Sheet2.Range("A" & cnt), Sheet1.Range("A2:A" & i), 1, 0)
    If lValue <> 0 Then
        Sheet2.Range("A" & cnt).Interior.Color = RGB(255, 255, 0)
    End If
      lValue = 0
Next

End Sub

Thanks

 

[Tim Hanson]

Hello Nebu,

I was reading about Matching functions, a lot of posts said that the method I was using was fast on large databases and not prone to erroring

I tested your code on 150,000 rows matching 300 rows and it went very fast

If I may ask another question, is there a way to post back the entire row of the matched cell

Thank you

 

[Tim Hanson]

I forgot to add if I add

 If lValue <> 0 Then
        Sheet2.Range("A" & cnt).Offset(0, 3).Interior.Color = RGB(255, 255, 0)
        Sheet2.Range("A" & cnt).Offset(0, 3) = lValue
    End If

I can post back the match to a different column from here is there a way to post back the entire row of the matched cell

 

[Nebu]

Hi:

If you want to copy the entire row. I guess you will have to use the match function . The match function can identify the row number of the matched cell , based on this you ask the macro to copy the entire row and paste it into a different location.

Thanks

 

[Tim Hanson]

Nebu,

Thanks again for help