Thank you so far..however
What if you do not know the names?
Galway- Tekst uit oorspronkelijk bericht niet weergeven -
- Tekst uit oorspronkelijk bericht weergeven -
Hi Galway,
If you do not know the names, and you dont want to mesh up your sheet
try this macro:
'-----------------Start
Public Sub CountUniqueValues()
ReDim strNames(0) As String
ReDim intCount(0) As Long
Dim lngLastRow As Long
Dim lngUniqueNames As Long
Dim rngSingle As Range
Dim intLastUnique As Integer
Dim intLoopUnique As Integer
Dim blnNotFound As Boolean
Dim strMessage As String
intLastUnique = -1
lngLastRow = Cells(1, 1).End(xlDown).Row
For Each rngSingle In Range(Cells(1, 1), Cells(lngLastRow,
1)).Cells
blnNotFound = True
If intLastUnique = -1 Then
strNames(0) = rngSingle.Value
intCount(0) = 1
intLastUnique = 0
Else
For intLoopUnique = 0 To intLastUnique
If strNames(intLoopUnique) = rngSingle.Value Then
intCount(intLoopUnique) = intCount(intLoopUnique)
+ 1
blnNotFound = False
Exit For
End If
Next
If blnNotFound Then
intLastUnique = intLastUnique + 1
ReDim Preserve strNames(intLastUnique) As String
ReDim Preserve intCount(intLastUnique) As Long
strNames(intLastUnique) = rngSingle.Value
intCount(intLastUnique) = 1
End If
End If
Next
strMessage = "Names" & vbTab & "Number" & vbNewLine
For intLoopUnique = 0 To intLastUnique
strMessage = strMessage & strNames(intLoopUnique) & _
vbTab & intCount(intLoopUnique) &
vbNewLine
Next
MsgBox strMessage
End Sub
'------------END
