Ich hab jetzt mal Ordnung reingebracht (du musst da zwingend Ordnung rein bringen in den Krautsalat!) - zumindest was die Unterkategorien angeht. Auch die Sache mit den Kontrollkästchen ist nun erstmal abgehakt (Achtung: Wortwitz!).

Das ganze wurde in einem Modul gesammelt (s.u.) - bitte benenn sie entsprechend wie angegeben, ist nur gut für dich selbst (und auch andere die mal reinschaun könnten).

Desweiteren im Anschluss daran auch noch mal das Modul welches die Funktionen zum Ändern des AutoFilters beinhaltet - mdlCommon, das dürftest du aber schon haben.

Du solltest alle anderen Module per Rechtklick entfernen (speichere sie zur Sicherheit ab, du wirst vor dem Entfernen danach gefragt)! Sonst gibt es Probleme.

Modul5 wirst du jedoch drinnen lassen müssen, weil dort Makros für die Kategorien hinterlegt sind. Wenn dort eine Funktion ModifyFilter drin steht, entferne diese Funktion. ModifyFilter darf im gesamten Projekt nur ein einziges mal vorkommen, nämlich im Modul mdlCommon (s. unten).

Was mit dem Code in den Klassenmodulen ist weiß ich nicht, hab ich mir nicht weiter angesehen.

Hier also nun das Modul für die Subcategory-Funktionen:

'+-------------------------------------
'|    name: mdlSubcatFuncs
'| purpose: handling subcategories
'| ------------------------------------
'| history:
'|  * 2014-05-20 created
'|
'|
'+-------------------------------------
Option Explicit

Private Const SC_MODULE_NAME As String = "mdlSubcatFuncs"

' Präfixe für das Element "Unterkategorie"
Private Const SC_FRM_PREFIX  As String = "scF_"
Private Const SC_CHK_PREFIX  As String = "scC_"

' Angaben über Datenquelle und Zielort (Visualisierungsort) der Elemente "Unterkategorie"
Private Const SC_WKS_SRC_NAME             As String = "Lists"
Private Const SC_WKS_SRC_1ST_CELLADDRESS  As String = "D3"
Private Const SC_WKS_DST_NAME             As String = "Checklist Structure"
Private Const SC_WKS_DATATABLE_NAME       As String = "Risk Category Checklist"

' Angaben zur Positionierung der Elemente "Unterkategorie"
Private Const SC_FRM_ANCHOR_LEFT  As Single = 211.5
Private Const SC_FRM_ANCHOR_TOP   As Single = 276.4688
Private Const SC_FRM_MARGIN_TOP   As Single = 29.2243

' Abmaße des Elements "Unterkategorie"
Private Const SC_FRM_WIDTH    As Single = 160.5
Private Const SC_FRM_HEIGHT   As Single = 19.5

' Abmaße des Kontrollkästchen zum jeweiligen Element "Unterkategorie"
Private Const SC_CHK_WIDTH    As Single = 13.2
Private Const SC_CHK_HEIGHT   As Single = 13.8

' Hintergrundfarben für das Element "Unterkategorie"
Private Const SC_FRM_RGB_STATE1 As Long = &HFFFFFF ' ? "&H" & Hex$(RGB(255, 255, 255))
Private Const SC_FRM_RGB_STATE2 As Long = &H99FFFF ' ? "&H" & Hex$(RGB(255, 255, 153))

'////////////////////////////////////////////////////////////////

Public Type TSubcategory
  Frame As Excel.Shape
  CheckBox As Object
End Type

'################################################################
'# PUBLIC
'################################################################

'////////////////////////////////////////////////////////////////
'//
Public Sub RemoveSubcategories()
  
  Dim shp As Excel.Shape
  
  With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
    
    Application.ScreenUpdating = False
    
    For Each shp In .Shapes
      If Left$(shp.Name, Len(SC_FRM_PREFIX)) = SC_FRM_PREFIX Then
        Call shp.Delete
      ElseIf Left$(shp.Name, Len(SC_CHK_PREFIX)) = SC_CHK_PREFIX Then
        Call shp.Delete
      End If
    Next
    
    Application.ScreenUpdating = True
    
  End With
  
End Sub

'////////////////////////////////////////////////////////////////
'//
Public Sub MakeSureSubcategoriesExists()
  
  Dim rngSubcats    As Excel.Range
  Dim rngSubcatCol  As Excel.Range
  Dim rngSubcatCell As Excel.Range
  Dim blnSuccess    As Boolean
  Dim blnSU         As Boolean
  
  blnSU = Application.ScreenUpdating
  Application.ScreenUpdating = False
  
  On Error GoTo ErrHandler
  
  With ThisWorkbook.Worksheets(SC_WKS_SRC_NAME)
    Set rngSubcats = .Range(SC_WKS_SRC_1ST_CELLADDRESS).CurrentRegion
    Set rngSubcats = .Range(.Range(SC_WKS_SRC_1ST_CELLADDRESS), rngSubcats.Cells(rngSubcats.Cells.Count))
  End With
  
  blnSuccess = True
  
  For Each rngSubcatCol In rngSubcats.Columns
    
    For Each rngSubcatCell In rngSubcatCol.Cells
      
      Select Case Trim$(rngSubcatCell.Text)
        Case "", "not sorted yet"
          Exit For 'Each rngSubcatCell
        Case Else
          If Not SubcategoryExists(rngSubcatCell) Then
            If Not CreateSubcategory(rngSubcatCell) Then
              blnSuccess = False
            End If
          End If
      End Select
      
    Next
    
  Next
  
  If blnSuccess Then
    Call MsgBox("Alle Unterkategorieren sind vorhanden bzw. wurden erstellt.", _
                vbInformation, _
                "Vorgang abgeschlossen")
  Else
    Call MsgBox("Einige Unterkategorien konnten nicht erstellt werden.", _
                vbExclamation, _
                "Vorgang abgeschlossen")
  End If
  
SafeExit:
  Application.ScreenUpdating = blnSU
  
Exit Sub
ErrHandler:
  Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
  GoTo SafeExit
End Sub

'////////////////////////////////////////////////////////////////
'//
Private Sub RefreshSubcategoryCheckBoxAll()
  
  Dim shp As Excel.Shape
  
  With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
    
    Application.ScreenUpdating = False
    
    For Each shp In .Shapes
      If Left$(shp.Name, Len(SC_CHK_PREFIX)) = SC_CHK_PREFIX Then
        Call RefreshSubcategoryCheckBox(shp.OLEFormat.Object)
      End If
    Next
    
    Application.ScreenUpdating = True
    
  End With
  
End Sub

'////////////////////////////////////////////////////////////////
'// check/uncheck checkbox for existing entries in "Risk Category Checklist"
Public Sub SubcategoryCheckBox_Click()
  
  Dim shpCheckBox   As Excel.Shape
  Dim strChkCaption As String
  Dim blnSU         As Boolean
  
  blnSU = Application.ScreenUpdating
  Application.ScreenUpdating = False
  
  On Error GoTo ErrHandler
  
  Select Case TypeName(Application.Caller)
    Case "String":  Set shpCheckBox = ActiveSheet.Shapes(Application.Caller)
    Case Else:      GoTo SafeExit
  End Select
  
  If Not shpCheckBox.Type = msoFormControl Then Exit Sub
  If Not shpCheckBox.FormControlType = xlCheckBox Then Exit Sub
  
  Call RefreshSubcategoryCheckBox(shpCheckBox.OLEFormat.Object)
  
SafeExit:
  Application.ScreenUpdating = blnSU
  
Exit Sub
ErrHandler:
  Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
  GoTo SafeExit
End Sub

'////////////////////////////////////////////////////////////////
'// assign filter in "Risk Category Checklist" by clicked subcategory's text
Public Sub SubcategoryFrame_Click()
  
  Dim rngAutoFilter   As Excel.Range
  Dim shpSubcat       As Excel.Shape
  Dim strShapeText    As String
  Dim blnSU           As Boolean
  
  blnSU = Application.ScreenUpdating
  Application.ScreenUpdating = False
  
  On Error GoTo ErrHandler
  
  Select Case TypeName(Application.Caller)
    Case "String":  Set shpSubcat = ActiveSheet.Shapes(Application.Caller)
    Case Else:      GoTo SafeExit
  End Select
  
  strShapeText = Trim$(shpSubcat.TextFrame2.TextRange.Text)
  
  With ThisWorkbook.Worksheets(SC_WKS_DATATABLE_NAME)
    'get/set range of AutoFilter
    If .AutoFilterMode Then
      Set rngAutoFilter = .AutoFilter.Range
    Else
      Call .Range(.Cells(5, "B"), .Cells(5, .Columns.Count).End(xlToLeft)).AutoFilter
      Set rngAutoFilter = .AutoFilter.Range
    End If
  End With
  
  If ToggleShapeColor(shpSubcat) = SC_FRM_RGB_STATE2 Then
    
    'set/modify filter for subcategory
    Call ModifyFilter(rngAutoFilter, 6, strShapeText)
    
  Else 'Unfilter
    
    'set/modify filter for subcategory
    Call ModifyFilter(rngAutoFilter, 6, strShapeText, mdaRemove)
    
  End If
  
SafeExit:
  Application.ScreenUpdating = blnSU
  
Exit Sub
ErrHandler:
  Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
  GoTo SafeExit
End Sub


'################################################################
'# PRIVATE
'################################################################


'////////////////////////////////////////////////////////////////
'//
Private Function SubcategoryExists(SubcategoryCell As Excel.Range) As Boolean
  
  Dim shp As Excel.Shape
  
  On Error GoTo ErrHandler
  
  With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
    Set shp = .Shapes(SC_FRM_PREFIX & SubcategoryCell.Address(False, False))
    Set shp = .Shapes(SC_CHK_PREFIX & SubcategoryCell.Address(False, False))
  End With
  
  SubcategoryExists = True
  
Exit Function
ErrHandler:
'  GetSubcategory = False
End Function

'////////////////////////////////////////////////////////////////
'//
Private Sub RefreshSubcategoryCheckBox(CheckBox As Object)
  
  Dim rngSubcategoryCol As Excel.Range
  Dim rngResult As Excel.Range
  
  Set rngSubcategoryCol = ThisWorkbook.Worksheets(SC_WKS_DATATABLE_NAME).Columns("G")
  Set rngResult = rngSubcategoryCol.Find(Trim$(CheckBox.Caption), LookIn:=xlValues, LookAt:=xlWhole)
  
  CheckBox.Value = Not (rngResult Is Nothing)
  
End Sub

'////////////////////////////////////////////////////////////////
'//
Private Function CreateSubcategory(SubcategoryCell As Excel.Range) As Boolean
  
  Dim rngFirstSubCatCell As Excel.Range
  Dim shpFrame As Excel.Shape
  Dim shpChk As Excel.Shape
  
  Set rngFirstSubCatCell = ThisWorkbook.Worksheets(SC_WKS_SRC_NAME).Range(SC_WKS_SRC_1ST_CELLADDRESS)
  
  With ThisWorkbook.Worksheets(SC_WKS_DST_NAME).Shapes
    
    Set shpFrame = .AddShape(MsoAutoShapeType.msoShapeRoundedRectangle, _
                  Left:=SC_FRM_ANCHOR_LEFT * (1! + (SubcategoryCell.Column - rngFirstSubCatCell.Column)), _
                  Top:=SC_FRM_ANCHOR_TOP + SC_FRM_MARGIN_TOP * (SubcategoryCell.Row - rngFirstSubCatCell.Row), _
                  Width:=SC_FRM_WIDTH, _
                  Height:=SC_FRM_HEIGHT)
    With shpFrame
      .Name = SC_FRM_PREFIX & Replace$(.Name, " ", "")
      .Fill.ForeColor.RGB = rgbWhite
      With .TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorCenter
        .TextRange.Font.Fill.ForeColor.RGB = rgbBlack
        .TextRange.Text = Trim$(SubcategoryCell.Text)
      End With
      .OnAction = SC_MODULE_NAME & ".SubcategoryFrame_Click"
    End With
    
    'Positions- und Größenangabe sind hier "sinnlos", aber notwendig
    Set shpChk = .AddFormControl(XlFormControl.xlCheckBox, _
                        Left:=0, _
                        Top:=0, _
                        Width:=0, _
                        Height:=0)
    With shpChk
      .Name = SC_CHK_PREFIX & Replace$(.Name, " ", "")
      With .OLEFormat.Object
        .Caption = Trim$(SubcategoryCell.Text)
        .Left = shpFrame.Left + 2!
        .Top = shpFrame.Top + (shpFrame.Height - SC_CHK_WIDTH) / 2!
        .Width = SC_CHK_WIDTH
        .Height = SC_CHK_HEIGHT
      End With
      .OnAction = SC_MODULE_NAME & ".SubcategoryCheckBox_Click"
    End With
    
    Call RefreshSubcategoryCheckBox(shpChk.OLEFormat.Object)
    
  End With
  
  CreateSubcategory = True
  
End Function

'////////////////////////////////////////////////////////////////
'// Change shape color on click in sheet "Checklist Structure"
Private Function ToggleShapeColor(Shape As Excel.Shape) As Long
  With Shape.Fill.ForeColor
    If .RGB = SC_FRM_RGB_STATE1 Then
      .RGB = SC_FRM_RGB_STATE2
    Else
      .RGB = SC_FRM_RGB_STATE1
    End If
    ToggleShapeColor = .RGB
  End With
End Function

Hier also noch das Modul mit den AutoFilter-Funktionen.

'+-------------------------------------
'|    name: mdlCommon
'| purpose:
'| ------------------------------------
'| history:
'|  * 2014-05-20 created
'|
'|
'+-------------------------------------
Option Explicit

Public Enum ModifyAction
  mdaAdd
  mdaRemove
End Enum
 
'################################################################
'# PUBLIC
'################################################################

'////////////////////////////////////////////////////////////////
'//
Public Sub ModifyFilter( _
    Range As Excel.Range, _
    Optional Field, Optional Value, _
    Optional Action As ModifyAction = mdaAdd _
)
  If Range Is Nothing _
    Then Exit Sub
   
  Dim blnField As Boolean
  Dim blnValue As Boolean
   
  blnField = Not (IsMissing(Field) Or IsEmpty(Field) Or IsNull(Field))
  blnValue = Not (IsMissing(Value) Or IsEmpty(Value) Or IsNull(Value))
   
  If Not blnField Then
  ' remove autofilter
    If Range.Worksheet.AutoFilterMode _
      Then Call Range.AutoFilter
    Exit Sub
  ElseIf blnField And Not blnValue Then
  ' remove field filters
    Call Range.AutoFilter(Field)
    Exit Sub
  End If
   
  Dim vntFilters As Variant
   
  On Error Resume Next
  With Range.Worksheet.AutoFilter.Filters(Field)
    vntFilters = .Criteria1
    If .Operator = xlOr _
      Then vntFilters = Array(vntFilters, .Criteria2)
  End With
  On Error GoTo 0
   
  Select Case Action
    Case mdaRemove
      Call RemoveElementFromArray1D(Value, vntFilters)
    Case Else 'mdaAdd
      Call AddElementToArray1D(Value, vntFilters)
  End Select
   
  'still filters available?
  If LBound(vntFilters) <= UBound(vntFilters) Then
  ' set field filters
    Call Range.AutoFilter(Field, vntFilters, xlFilterValues)
  Else
  ' remove field filters
    Call Range.AutoFilter(Field)
  End If
   
End Sub


'################################################################
'# PRIVATE
'################################################################


'////////////////////////////////////////////////////////////////
'//
Private Sub AddElementToArray1D(Expression As Variant, ByRef Array1D As Variant)
  If IsArray(Array1D) Then
    ReDim Preserve Array1D(LBound(Array1D) To UBound(Array1D) + 1)
    Array1D(UBound(Array1D)) = Expression
  ElseIf Not (IsEmpty(Array1D) Or IsNull(Array1D)) Then
    Array1D = Array(Array1D, Expression)
  Else
    Array1D = Array(Expression)
  End If
End Sub
 
'////////////////////////////////////////////////////////////////
'//
Private Sub RemoveElementFromArray1D( _
    Expression As Variant, _
    ByRef Array1D As Variant, _
    Optional Count As Long _
)
  Dim i&, n&
   
  If IsEmpty(Array1D) Or IsNull(Array1D) Then
    Array1D = Split(Empty)
     
  ElseIf Not IsArray(Array1D) Then
     
    If InStr(1, Array1D, Expression, vbTextCompare) Then
      Array1D = Split(Empty)
    Else
      Array1D = Array(Array1D)
    End If
     
  Else
     
    i = LBound(Array1D)
     
    Do While i <= UBound(Array1D)
      If InStr(1, Array1D(i), Expression, vbTextCompare) Then
        If Count <= 0 Or n < Count _
          Then n = n + 1
      ElseIf n > 0 Then
        Array1D(i - n) = Array1D(i) 'shift element up
      End If
      i = i + 1 'next element
    Loop
     
    If n > 0 Then
      If LBound(Array1D) <= UBound(Array1D) - n Then
        ReDim Preserve Array1D(LBound(Array1D) To UBound(Array1D) - n)
      Else
        Array1D = Split(Empty)
      End If
    End If
     
  End If
   
End Sub

Gruß