Find duplicate beds in list

[arjan kooger]

Good afternoon,

I have a bed list with names in column B and bed numbers in column L ( like 10T, 10B, 11T, 11B etc.).

i use a macro that works pretty well, but it shows only the first names in a message box (in Another sheet) if there are duplicates.

Can anyone help me with a macro what will show both names in the same bed in a message box?

Thanks in advance!

A B L

1	Adamson (N)										17T
2	Aquilina (N)										16T
3	Bacic (N)										34T
4	Buruiana (N)										11T
5	Butter										50B
6	Ciparis										57B
7	Devic (N)										09T
8	Gray										11T
9	Halliday (N)										51B
10	Hoeksema (N)										10T
11	Hoekstra										40T
12	Jozic										13T
13	Kristkalns										41B
14	Martin										13T
15	Mifsud										56B
16	Mitrofanovs										34T
17	Muscat										09T
18	Pauli										12T
19	Penava										42B
20	Rancans										17T
21	Rocha										16T
22	Sinenkij (N)										13T
23	Srac (N)										15T

Sub Test()

ThisWorkbook.Sheets("POB").Activate

Set R = Range("L4", Range("L" & Rows.Count).End(xlUp))

For Each c In R

D = Cells(c.Row, c.Column - 10).Value

If WorksheetFunction.CountIf(R, c) > 1 Then If InStr(1, s, c) = 0 Then s = s & c & "," & " - " & D & vbCr

Next

ThisWorkbook.Sheets("All").Activate

MsgBox IIf(s <> "", "Duplicate beds in the List" & vbLf & Mid(s, 1), "No duplicates")

End Sub

 

[Kaper]

Try such code:

Sub Test()
Dim R As Variant, dict As Object, key As Variant, i As Long, s As String
Set dict = CreateObject("Scripting.Dictionary")
With ActiveWorkbook.Sheets("POB")
  R = .Range("B4", .Range("L" & .Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(R)
  key = R(i, 11)
  If dict.exists(key) Then
    dict(key) = dict(key) & ", " & R(i, 1)
  Else
    dict(key) = R(i, 1)
  End If
Next i
For Each key In dict
  If InStr(dict(key), ", ") > 0 Then s = s & dict(key) & " - " & key & vbCr
Next key
' ActiveWorkbook.Sheets("All").Activate
MsgBox IIf(s <> "", "Duplicate beds in the List:" & vbLf & s, "No duplicates")
End Sub

PS. By using CODE tags, the readability of the code on forum is significantly improved

 

[arjan kooger]

Thank you Kaper, this is what i was looking for!!!

I did alter the code a bit coz since in the original list there are spaces and group names it did show those group names as wel.

I Changed start row to B14 and change

If InStr(dict(key), ", ") > 1

in "1" seems to solve the problem.

Thanks Again!! Problem solved!

Dim R As Variant, dict As Object, key As Variant, i As Long, s As String
Set dict = CreateObject("Scripting.Dictionary")
With ActiveWorkbook.Sheets("POB")
  R = .Range("B14", .Range("L" & .Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(R)
  key = R(i, 11)
  If dict.exists(key) Then
    dict(key) = dict(key) & ", and  " & R(i, 1)
  Else
    dict(key) = R(i, 1)
  End If
Next i
For Each key In dict
  If InStr(dict(key), ", ") > 1 Then s = s & dict(key) & "  -  " & key & vbCr
Next key
ActiveWorkbook.Sheets("All").Activate
MsgBox IIf(s <> "", "Duplicate beds in the List:" & vbCrLf & vbLf & s, "No duplicates")