Hi
This is untested, so i'd be amazed if it works first time - sorry but
i'm too busy to polish it at the mo.
To carry the number of duplicates with you I've had to redo your loop
and add all the data to the listbox as a single two coulmn array. You
will have to make your listbox a 2 column one with the second column
hidden.
regards
Paul

Private Sub ListBox1_Change()
Application.ScreenUpdating = False
ListBox3.Clear
TextBox5.Value = ""
If ListBox2.ListCount 0 Then ListBox2.Clear
Dim LastCell As Long
Dim myrow As Long
Dim NoDupes As Collection`, TempDupes as Collection
Dim myArray(0 to 1) as Variant, ListArray() as Variant
Dim DupesCount as Long, TempValue as integer

On Error Resume Next
LastCell = Worksheets("Data").Cells(Rows.Count, "BH").End(xlUp).Row
With ActiveWorkbook.Worksheets("Data")
.Select
Set NoDupes = New Collection
Set TempDupes = New Collection
err.clear
'get the values for a two column listbox
For myrow = 1 To LastCell
If .Cells(myrow, 5).Value = ListBox1.Value Then
If .Cells(myrow, 60) < "" Then
TempDupes.Add 1, CStr(.Cells(myrow, 60).Value)
If Err.Number = 0 Then 'new value
myArray(0) = CStr(.Cells(myrow, 60).Value)
myArray(1) = 1
NoDupes.Add myArray, CStr(.Cells(myrow,
60).Value)
Else 'value exists
TempValue = NoDupes(CStr(.Cells(myrow, 60).Value) ) (1)
'count
NoDupes.Remove CStr(.Cells(myrow, 60).Value)
myArray(0) = CStr(.Cells(myrow, 60).Value)
myArray(1) = TempValue+1
NoDupes.Add myArray, CStr(.Cells(myrow, 60).Value)
'contains updated count
Err.Clear
End If
End If
End If
Next
End With
'Update the Listbox
DupesCount = NoDupes.count
ReDim ListArray(0 to DupesCount-1, 0 to 1)
For i = 0 to DupesCount-1
For j = 0 to 1
ListArray(i,,j) = NoDupes(i+1)(j)
Next j
Next i
Listbox2.List = ListArray
TextBox6.Value = ListBox2.ListCount
TextBox8.Value = Listbox2.List(ListIndex,1)
Application.ScreenUpdating = True
End Sub