Hi Perico,

Try this one.

Regards,
KL

Sub finddups()
Dim j As Long, rng As Range, test As Variant
Dim Values As Variant, Times As Variant
Dim MyStr As String, c As Range, sLine As Variant

With Worksheets("Master")
For Each c In .Range("B28", .Cells(.Rows.Count, "B").End(xlUp))
MyStr = c & c.Offset(, 1) & c.Offset(, 2) & c.Offset(, 6)
If j = 0 Then
test = CVErr(xlErrNA)
ReDim Values(1 To 1)
ReDim Times(1 To 1)
ReDim sLine(1 To 1)
Else
test = Application.Match(MyStr, Values, 0)
End If
If IsError(test) Then
j = j + 1
ReDim Preserve Values(1 To j)
ReDim Preserve Times(1 To j)
ReDim Preserve sLine(1 To j)
Values(j) = MyStr
Times(j) = 1
sLine(j) = c.Offset(, -1)
Else
Times(test) = Times(test) + 1
sLine(test) = sLine(test) & ", " _
& c.Offset(, -1)
End If
Next c
.Range("J28").Resize(UBound(Values)) = _
Application.Transpose(sLine)
.Range("K28").Resize(UBound(Values)) = _
Application.Transpose(Values)
.Range("L28").Resize(UBound(Values)) = _
Application.Transpose(Times)
End With
End Sub