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.