The code makes use of the SendMessage API along with the ListBox LB_FINDSTRINGEXACT windows message to detect duplicate items. If you were changing the code to work with a combo, you would use the CB_FINDSTRINGEXACT message instead.
private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (byval hwnd as Long, byval wMsg as Long, _ byval wParam as Long, lParam as Any) as Long private Const LB_FINDSTRINGEXACT = &H1A2 private Sub Command1_Click() Dim iIndex as Long Dim iMatch as Long Dim iCopies as Long Dim iHighest as Long Dim aCommon() as Long Dim sString as string Dim bSkip as Boolean for iIndex = 0 to List1.ListCount - 1 iCopies = 0 iMatch = -1 bSkip = false 'Skip this one if it's the same as the last Item Checked If iIndex then bSkip = (List1.List(iIndex) = List1.List(iIndex - 1)) End If 'Skip this one if there's a previous instance of it in the List If Not bSkip then bSkip = (SendMessage(List1.hwnd, LB_FINDSTRINGEXACT, -1, _ byval List1.List(iIndex)) < iIndex) End If 'While there are other Instances in the List.. While iMatch <> iIndex And Not bSkip 'Increment the No of Copies Found of this Item iCopies = iCopies + 1 'Find the next Copy.. iMatch = SendMessage(List1.hwnd, LB_FINDSTRINGEXACT, _ IIf(iMatch < 0, iIndex, iMatch), _ byval List1.List(iIndex)) Wend 'If there were more than 1 Copies If iCopies > 1 And Not bSkip then 'If the No. of Copies is Greater or the Same as the Highest so far.. If iCopies >= iHighest then If iCopies > iHighest then 'new Highest Copies ReDim aCommon(0) else 'Another Item with the same highest amount of Copies ReDim Preserve aCommon(UBound(aCommon) + 1) End If 'Store this Index aCommon(UBound(aCommon)) = iIndex 'Remember the Highest No. of Copies iHighest = iCopies End If End If next If iHighest then 'If Copies were Found.. for iIndex = 0 to UBound(aCommon) sString = sString & ", " & List1.List(aCommon(iIndex)) next MsgBox "Most Repeated Item(s): " & vbCrLf & mid$(sString, 3) & _ vbCrLf & vbCrLf & "Repeated " & iHighest & " Times.", _ vbInformation + vbOKOnly, "Repeats" else 'No Copies Found.. MsgBox "No Items were Repeated", vbInformation + vbOKOnly, _ "No Repeats" End If End Sub ' '
Download Zipped Project file (5k)