”Exact Match
Sub FindMatchAndPastTo3Sheet()
Dim xlRange As Range
Dim xlCell As Range
Dim xlSheet As Worksheet
Dim valueToFind
Count = Sheets(“Sheet1”).Range(“$A:$A”).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Count
MsgBox “Sheet1 count =” & Count
Count2 = Sheets(“Sheet2”).Range(“$A:$A”).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Count
MsgBox “Sheet2 count =” & Count2
For i = 2 To Count
valueToFind = Sheets(“Sheet1”).Range(“A” & i).Value
‘MsgBox “Sheet 1 Value =” & valueToFind
If valueToFind <> “” Then
Set rWhere = Sheets(“Sheet2”).Range(“A2:A” & Count2) ”Looking values within the range A2 to A13
”Finding exact match:
Set r = rWhere.Find(what:=valueToFind, After:=rWhere(1), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not r Is Nothing Then
‘MsgBox “Match found =” & r
FirstAddress = r.Address
‘MsgBox “Found in = ” & cellAddress
r.Offset(0, 1).Value = “X” ‘puting x at the right coloumn of the finding cell
”Looping to find multiple values in the sheet2
Do
‘mark the cell in the column to the right if “Ron” is found
r.Offset(0, 1).Value = “X”
Set r = rWhere.FindNext(r)
newRaddress = r.Address
sd = Split(newRaddress, “$”)
‘MsgBox sd(2)
Worksheets(“Sheet2”).Range(newRaddress).Copy Worksheets(“Sheet3”).Range(“B” & sd(2))
Worksheets(“Sheet3”).Range(“C” & sd(2)).Value = r
‘Worksheets(“Sheet3”).Range(“D” & i).Value = sd(1) & sd(2) + 2
Worksheets(“Sheet2”).Range(“C” & sd(2)).Copy Worksheets(“Sheet3”).Range(“E” & sd(2))
Loop While Not r Is Nothing And r.Address <> FirstAddress
‘Range.Copy to other worksheets
Worksheets(“Sheet1”).Range(“A” & i).Copy Worksheets(“Sheet3”).Range(“A” & i)
‘Worksheets(“Sheet2”).Range(r.Address).Copy Worksheets(“Sheet3”).Range(“B” & i)
‘Worksheets(“Sheet3”).Range(“C” & i).Value = r
End If
End If
Next
End Sub