Offset function with FIND function

[Arafat]

Hello All,

I have a requirement where i have to search a value of cell in the C:C range and find all values found in that column, if the values are found then i have to copy the value of first string in A:A range.
Example:

A B C
1 Cat Cat
2 tiger Cat
3 son Cat

here in column C Cat is repeated thrice, and in column A it has different values, i want the values of Coulmn A to replace it by first value in A.

Output:

A B C
1 Cat Cat
1 tiger Cat
1 son Cat

here is the piece of code that i have.

Sub comparecol()
Dim FindString As String
Dim Rng As Range
Dim Bcell As Range
Dim ws1 As Worksheet
Dim nn, nn1 As String
For Each Rng In Range("C:C")
nn1 = Rng.Cells.Offset(0, -2)
'nn = ws1.Name
FindString = Rng

'FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)



If Rng = FindString Then
'Rng.Cells.Select
Rng.Cells.Offset(0, -2).Value = nn1
End If
End With
End If
Next Rng
End Sub


Thanks a lot for timely help.

 

[Tinbendr]

Sub Test()

Dim WS As Worksheet
Dim LastRow As Long
Dim Unique As New Collection
Dim aCell As Range
Dim Temp$
Dim A As Long

Set WS = ActiveWorkbook.Worksheets(1)

With WS
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    

    For Each aCell In .Range("C1:C" & LastRow)
    On Error Resume Next
        Unique.Add aCell.Value, aCell.Value
    Next
    
    On Error GoTo 0
    For A = 1 To Unique.Count
    
    Set C = .Range("C1:C" & LastRow).Find(Unique(A), LookIn:=xlValues)
    If Not C Is Nothing Then
        firstAddress = C.Address
        Temp$ = C.Offset(, -2).Value
        Do
            C.Offset(, -2).Value = Temp$
            Set C = .Range("C1:C" & LastRow).FindNext(C)
        Loop While Not C Is Nothing And C.Address <> firstAddress
    End If
    Next
End With

End Sub