Seek matching text in cells and if match found enter info in third cell

[krackers]

I am trying to sort some code that basically looks down a column of data and if the text in one cell in that column matches exactly the text in another cell in that same column it produces a result in a separate column but in the row where the first element of the match was found. The result being a third piece of text e.g. "match found".

So say column 1 had the word "red lorry" in rows 4 and 10 then "match found" would be given in column 2 row 4 and col 2 row 10 would be left blank.

I am assuming I need a loop to work from the first cell to the last cell of the column with data.

It would be greatly appreciated if someone would point in the right direction to get the code going, thanks.

[Paul_Hossler]

Option Explicit


Sub MarkDups()
    Dim C As Collection
    Dim r As Range, r1 As Range
    Dim v As Variant
    
    'input data
    Set r = ActiveSheet.Cells(1, 1)
    Set r = Range(r, r.End(xlDown))
    
    'collection for unique items
    Set C = New Collection
    
    'fill collection, item = address of first occurrence, key = value
    For Each r1 In r.Cells
        On Error Resume Next
        C.Add r1.Address, r1.Value
        On Error GoTo 0
    Next
    
    'count number of occurrences, if > 1 mark next column
    For Each v In C
        If Application.WorksheetFunction.CountIf(r, Range(v).Value) > 1 Then
            Range(v).Offset(0, 1).Value = "match found"
        End If
    Next


End Sub

[krackers]

Thanks Paul. Most grateful. I now need to transpose it to the actual situation and hopefully I can do that without further help. Again many thanks.

After asking for help, I did manage to get some code written myself that worked but a completely different approach to you and less elegant - my knowledge being far more basic I guess! In my case I also knew I would have to first sort the data which I knew would then put the matching info I actually have in two adjacent rows, I also knew that I would never have more than two matching entries.

My solution is below:

Sub CombineNames()
Dim lrow As Long
Dim i As Long
lrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
 
    For i = 2 To lrow
       If Worksheets("Sheet1").Cells(i, 5).Text = Worksheets("TAM").Cells(i + 1, 5).Text  Then
               Worksheets("Sheet1").Cells(i, 1).Value = "Match Found"
       End If
   Next
End Sub

David

PS Now transposed your code to my actual sheet made adjustments and all working just fine so thanks.