Solved: Give result for duplications

[Gil]

Hello
I now have a code with the help of VBA Express that needs one more tweek.
The workbook has 2 sheets, sheet 2 has some data on it and when the code is run it finds the match and 3 references in sheet 1 and places the value in an offset position on sheet 2 to the required data.

What I want help with is this
When a duplication or more is found a record is also made. I would never expect more than 2 but think I need to allow for 3.
Gil

[mdmackillop]

Option Explicit
Sub FindwithNotFound()
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim i As Long
Dim FirstAddress As String
Set Sh = Sheets("Sheet1")
Do
i = 1
Set c = ActiveCell
With Sh.Cells
Set Fnd = .Find(Trim(Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then

FirstAddress = Fnd.Address
Do
c.Offset(, i) = .Cells(2, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
ActiveCell.Offset(, i).Font.Bold = True
ActiveCell.Offset(, i).Font.Color = -16776961
Set Fnd = .FindNext(Fnd)
i = i + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> FirstAddress
Else
c.Offset(, i) = "Not found"
ActiveCell.Offset(, i).Font.Bold = True
ActiveCell.Offset(, i).Font.Color = -16776961
End If
ActiveCell.Offset(-1, 0).Select
End With
Loop Until IsEmpty(ActiveCell)
End Sub

[mdmackillop]

Avoiding Selection


Sub FindwithNotFound2()
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim i As Long
Dim FirstAddress As String
Dim Rng As Range
Set Sh = Sheets("Sheet1")
Set Rng = Range(Sheets("Sheet2").Cells(7, 6), _
Sheets("Sheet2").Cells(Rows.Count, 6).End(xlUp))
For Each c In Rng
i = 1
With Sh.Cells
Set Fnd = .Find(Trim(Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstAddress = Fnd.Address
Do
c.Offset(, i) = .Cells(2, Fnd.Column - 0) & "-" & _
Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
c.Offset(, i).Font.Bold = True
c.Offset(, i).Font.Color = -16776961
Set Fnd = .FindNext(Fnd)
i = i + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> FirstAddress
Else
c.Offset(, i) = "Not found"
c.Offset(, i).Font.Bold = True
c.Offset(, i).Font.Color = -16776961
End If
End With
Next
End Sub