VBA: Tabelle durchsuchen -> gleiche Werte der Kategorie zählen -> Statistik erst

Option Explicit

Type my_Daten_struct
  zeile   As Long
  bChkBox As Boolean
  sName   As String
  sVorname As String
  lGruppe  As Long
End Type

'Spaltennummern
Private Const cSP_CHECKBOX = 1
Private Const cSP_NAME = 2
Private Const cSP_VORNAME = 3
Private Const cSP_GRUPPE = 4

'*************************************************************************************
Sub DatenMitCheckboxenSammelnUndAuswerten()
  
'  Sheet ist wie folgt aufgebaut:
'  -------------------------------------
'  Spalte A: enthält in jeder Zeile eine Checkbox
'  Spalte B: Name
'  Spalte C: Vorname
'  Spalte D: GRUPPEN (Möglichkeiten: 1 Freizeit, 2 Sport, 3 Schule, 4 Kollege)

  Dim ws As Worksheet
  Dim MyDaten() As my_Daten_struct, MyDatenCnt As Long, x As Long
  
 ->Datenfeld erstmal für 20 Einträge einrichten
  ReDim MyDaten(1 To 20)
  MyDatenCnt = 0
  
 ->aktuelle Blatt setzen
  Set ws = ActiveSheet
  
 ->Zuerst nach Zeilen mit Checkbox suchen und Zeile + Wert merken
  Call CheckboxInformationenSammeln(ws, cSP_CHECKBOX, MyDaten(), MyDatenCnt)
  
 ->weitere Daten zu den Zeilen auslesen
  For x = 1 To MyDatenCnt
    MyDaten(x).sName = ws.Cells(MyDaten(x).zeile, cSP_NAME).Value
    MyDaten(x).sVorname = ws.Cells(MyDaten(x).zeile, cSP_VORNAME).Value
    MyDaten(x).lGruppe = ws.Cells(MyDaten(x).zeile, cSP_GRUPPE).Value
  Next
  
 ->Auswertung
  Call Auswertung(ws, MyDaten(), MyDatenCnt)
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'*************************************************************************
Private Function Auswertung(ws As Worksheet, _
                            MyDaten() As my_Daten_struct, _
                            MyDatenCnt As Long)
                            
  Dim lAnzFreizeit As Long, lAnzSport  As Long, lAnzSchule As Long
  Dim lAnzKollege  As Long, lAnzAndere As Long, x As Long
  
  For x = 1 To MyDatenCnt
    If MyDaten(x).bChkBox Then
      Select Case MyDaten(x).lGruppe
        Case 1:     lAnzFreizeit = lAnzFreizeit + 1
        Case 2:     lAnzSport = lAnzSport + 1
        Case 3:     lAnzSchule = lAnzSchule + 1
        Case 4:     lAnzKollege = lAnzKollege + 1
        Case Else:  lAnzAndere = lAnzAndere + 1
      End Select
    End If
  Next
  
 ->Ausgabe
  
'  ---------------------------------------------------------------
'  Anzahl Mitglieder:
'  --------------------------
'  Gruppe 1 (Freizeit): 5
'  Gruppe 2 (Sport):6

  MsgBox _
    --------------------------------------------------------------- & vbLf & _
    Anzahl der Mitglieder: & vbLf & _
    -------------------------- & vbLf & _
    Gruppe 1 (Freizeit):  & lAnzFreizeit & vbLf & _
    Gruppe 2 (Sport):  & lAnzSport & vbLf & _
    Gruppe 3 (Schule):  & lAnzSchule & vbLf & _
    Gruppe 4 (Kollege):  & lAnzKollege & vbLf & _
    nicht zugeordnet:  & lAnzAndere
End Function

'*************************************************************************
Private Function CheckboxInformationenSammeln(ws As Worksheet, _
                                              lSpalteChkBoxen As Long, _
                                              MyDaten() As my_Daten_struct, _
                                              MyDatenCnt As Long)
  
  Dim obj As Object
  
 ->alle OLE-Objecte
  For Each obj In ws.OLEObjects
   ->Ist Checkbox ?
    If obj.ProgId = Forms.CheckBox.1 Then
     ->ist in Spalte lSpalteChkBoxen ?
      If obj.TopLeftCell.Column = lSpalteChkBoxen Then
        MyDatenCnt = MyDatenCnt + 1
        If UBound(MyDaten()) < MyDatenCnt Then
         ->weiter 20 Einträge einrichten
          ReDim Preserve MyDaten(1 To MyDatenCnt + 19)
        End If
       ->Zeile, CheckboxWert merken
        MyDaten(MyDatenCnt).zeile = obj.TopLeftCell.Row
        MyDaten(MyDatenCnt).bChkBox = obj.Object.Value
      End If
    End If
  Next

AUFRAEUMEN:
  Set obj = Nothing
End Function