Häufigkeit von Werten ermitteln

Manchmal möchte man wissen, wie oft ein Wert in einem Bereich vorkommt. Dazu kann man die Tabellenfunktion Zählenwenn verwenden. Will man wissen, wie häufig unbekannte Werte in einem Bereich vorkommen, sollte man sich eine Pivot-Tabelle anschauen. Ein kleines Makro schafft das aber auch. Möglicherweise ist die Methode bei größeren Bereichen etwas langsam, aber Geschwindigkeit ist bekanntlich relativ.

Beispielmappe (histogramm.zip 17 KB
 

'Click-Ereignis von Buttons auf einem Tabellenblatt
'Der Bereich hat den Namen "Testbereich"

Private Sub cmbAnzeigen_Click()
    WerteZählenAnzeigen Me.Range("Testbereich")
End Sub

Private Sub cmbListe_Click()
Dim x As Collection, i As Long
Set x = Zählen(Me.Range("Testbereich"))
Me.Range("A6:B65536").ClearContents
For i = 1 To x.Count
    Me.Cells(i + 5, 1) = x(i)("Anzahl")
    Me.Cells(i + 5, 2) = x(i)("Wert")
Next
End Sub

'In ein Modul

Option Explicit
Public Function Zählen(Bereich As Range) As Collection
Dim x As New Collection, y As Variant
Dim z As Collection, Anzahl As Long
On Error Resume Next 'Wichtig
For Each y In Bereich
    'Eine neue Collection für Wert und Anzahl anlegen
    Set z = New Collection
    'Wert ablegen
    z.Add y.Value, "Wert"
    'Anzahl auf 1
    z.Add 1, "Anzahl"
    'Das Error Objekt zurücksetzen
    Err.Clear
    'Jeder Schlüssel einer Collection ist einmalig.
    'Beim Versuch, einen neuen Eintrag mit dem gleichen
    'Key zu erstellen, gibt es einen Fehler, der aber
    'durch die Zeile 'On Error Resume Next' ignoriert wird.
    'Deshalb für beliebig viel gleiche Werte nur ein Item.
    If y <> "" Then x.Add z, "X" & y.Value
    If Err.Number > 0 Then
        'Der Eintrag ist schon mal vorhanden
        'Erst einmal Anzahl ermitteln
        Anzahl = x("X" & y.Value)("Anzahl")
        'Eine neue Collection für Wert und Anzahl anlegen
        Set z = New Collection
        'Wert ablegen
        z.Add y.Value, "Wert"
        'Anzahl auf Anzahl + 1
        z.Add Anzahl + 1, "Anzahl"
        'Erst alten Eintrag löschen
        x.Remove ("X" & y.Value)
        'Dann neuen mit neuer Anzahl anlegen
        x.Add z, "X" & y.Value
    End If
Next
Set Zählen = x
End Function

Public Sub WerteZählenAnzeigen(Bereich As Range)
Dim x As New Collection, y As Variant
Dim z As Collection, Anzahl As Long
Dim Meldung As String
On Error Resume Next 'Wichtig
For Each y In Bereich
    'Eine neue Collection für Wert und Anzahl anlegen
    Set z = New Collection
    'Wert ablegen
    z.Add y.Value, "Wert"
    'Anzahl auf 1
    z.Add 1, "Anzahl"
    'Das Error Objekt zurücksetzen
    Err.Clear
    'Jeder Schlüssel einer Collection ist einmalig.
    'Beim Versuch, einen neuen Eintrag mit dem gleichen
    'Key zu erstellen, gibt es einen Fehler, der aber
    'durch die Zeile 'On Error Resume Next' ignoriert wird.
    'Deshalb für beliebig viel gleiche Werte nur ein Item.
    If y <> "" Then x.Add z, "X" & y.Value
    If Err.Number > 0 Then
        'Der Eintrag ist schon mal vorhanden
        'Erst einmal Anzahl ermitteln
        Anzahl = x("X" & y.Value)("Anzahl")
        'Eine neue Collection für Wert und Anzahl anlegen
        Set z = New Collection
        'Wert ablegen
        z.Add y.Value, "Wert"
        'Anzahl auf Anzahl + 1
        z.Add Anzahl + 1, "Anzahl"
        'Erst alten Eintrag löschen
        x.Remove ("X" & y.Value)
        'Dann neuen mit neuer Anzahl anlegen
        x.Add z, "X" & y.Value
    End If
Next
'Anzahl der Items in der Collection ermitteln
Meldung = x.Count & " verschiedene Werte gefunden" & vbCrLf
For Each y In x
    'Alle Items der Collection durchlaufen und die Werte
    'zu einem String zusammensetzen.
    Meldung = Meldung & y("Anzahl") & " mal " & y("Wert") & vbCrLf
Next
'Die Msgbox kann aber leider nur eine begrenzte Zahl Zeilen darstellen
MsgBox Meldung
End Sub