Partial matching between two columns and copy corresponding cell VBA

Question

I am trying to do a partial comparison between 2 columns from 2 different sheets in the same workbook. For example: Sheet2's Column B contains the "Rs ID" and Column A contains "Clinical Significance" and in Sheet1 there are 2 columns A & B as well with the same headers.

If there is a partial match in column B of Sheet2 with column B of Sheet1, I will want my VBA code to copy the cell in Column A from Sheet2 to the same cell in in Column A in Sheet1.

Sheet 1 Sheet 2

This is my code. It runs perfectly but it doesnt seem to capture any data as the column B in sheet 2 is not exactly the same as column A. Could it be I coded the .xlpart incorrectly?

Sub test()
Dim rng2 As Range, c2 As Range, cfind As Range
Dim x, y
With Worksheets("sheet1")
  Set rng2 = Range(.Range("B2"), .Range("B2").End(xlDown))
  For Each c2 In rng2
  x = c2.Value
 With Worksheets("sheet2").Columns("b:B")
On Error Resume Next
Set cfind = .Cells.Find(what:=x, lookat:=xlpart)
 If cfind Is Nothing Then GoTo line1
  y = cfind.Offset(0, -1).Value
  End With
   c2.Offset(0, -1) = y
   line1:
   Next c2
End With

End Sub

sancho.s ReinstateMonicaCellio sancho.s ReinstateMonicaCellio · Accepted Answer · 2017-11-02T02:35:42

Try code below. LookIn:=xlValues was the essential missing part.

PS: Using Goto is typically considered not good practice. I eliminated it, by using If (Not (cfind Is Nothing)).

Sub test()
    Dim rng2 As Range, c2 As Range, cfind As Range
    Dim x, y
    With Worksheets("sheet1")
        Set rng2 = .Range(.Range("B2"), .Range("B2").End(xlDown))
        For Each c2 In rng2
            x = c2.Value
            With Worksheets("sheet2").Columns("B:B")
                On Error Resume Next
                Set cfind = .Cells.Find(what:=x, lookat:=xlPart, LookIn:=xlValues)
                If (Not (cfind Is Nothing)) Then
                    y = cfind.Offset(0, -1).Value
                    c2.Offset(0, -1) = y
                End If
            End With
        Next c2
    End With
End Sub

Partial matching between two columns and copy corresponding cell VBA

1 Answers