Hab es mal bei mir nachgebaut und es läuft, Code in Sheet8:

Achtung (hab ich noch nicht erwähnt): Wenn du in der Liste neue Einträge vornimmst verschieben sich dadurch die Zelladdressen, was wiederum dann sich auf die Namen der Frames und Checkboxes auswirkt (zeigt dann auf die falsche Zelle).

Darum musst du nach einer Änderung (hinzufügen / entfernen von Spalten / Zeilen) mit RemoveSubcategories alle Placketten entfernen und dann mit MakeSureSubcategoriesExists neu erstellen lassen.

'+-------------------------------------
'|    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
'################################################################

'////////////////////////////////////////////////////////////////
'//
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

'////////////////////////////////////////////////////////////////
'//
Public 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
  Dim strFind As String
  
  strFind = Mid$(CheckBox.Name, Len(SC_CHK_PREFIX) + 1)
  strFind = ThisWorkbook.Worksheets(SC_WKS_SRC_NAME).Range(strFind).Text
  
  Set rngSubcategoryCol = ThisWorkbook.Worksheets(SC_WKS_DATATABLE_NAME).Columns("G")
  Set rngResult = rngSubcategoryCol.Find(strFind, 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 & SubcategoryCell.Address(False, False) '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 = "'" & ThisWorkbook.Name & "'!" & Me.CodeName & ".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 & SubcategoryCell.Address(False, False) '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 = "'" & ThisWorkbook.Name & "'!" & Me.CodeName & ".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

'Option Explicit
'
'
'Private Sub Worksheet_Change(ByVal Target As Range)
''Whenever the sheet "Lists" is changed, the name list for the checkboxes is refreshed
'Application.EnableEvents = False
'
'Dim nZeile As Integer
'Dim vSpalte As Integer
'Dim vZeile As Integer
'Dim nSpalte As Integer
'Dim vSheet As String
'Dim nSheet As String
'
'vSheet = "Lists"
'nSheet = "Lists" 'Target sheet
'nZeile = 1 'Target row
'nSpalte = 18 'Target column
'
'For vSpalte = 4 To 7 'Relevant entries for the refreshed list
'    For vZeile = 3 To Sheets(vSheet).Cells(65536, vSpalte).End(xlUp).Row
'        Sheets(nSheet).Cells(nZeile, nSpalte) = Sheets(vSheet).Cells(vZeile, vSpalte)
'        nZeile = nZeile + 1
'    Next
'Next
'
''Execute subs below
'DeleteCells
'DeleteBlanks
'RenameCheckBox
'
'Application.EnableEvents = True
'
'Exit Sub
'
'End Sub
'
'Private Sub DeleteCells()
''removes "not sorted yet" as a subcategory for naming checkboxes
'    Dim c As Range
'    Dim SrchRng
'    Dim ws As Excel.Worksheet
'
'    Set ws = Worksheets("Lists")
'    Set SrchRng = ws.Range("R1", ws.Range("R65536").End(xlUp))
'    Do
'        Set c = SrchRng.Find("not sorted yet", LookIn:=xlValues)
'        If Not c Is Nothing Then c.Delete
'    Loop While Not c Is Nothing
'End Sub
'
'Private Sub RenameCheckBox()
''Automatically refresh checkbox names from defined list
'  Dim rngNames As Excel.Range
'  Dim shp As Excel.Shape
'  Dim i As Long
'
'  On Error GoTo ErrHandler
''Hidden column with list of names (all subcategories)
'  Set rngNames = Worksheets("Lists").Range("R:R")
'
'  With Worksheets("Checklist Structure")
'
'    For Each shp In .Shapes
'      If shp.Type = msoFormControl Then
'        If shp.FormControlType = xlCheckBox Then
'          If i < rngNames.Cells.Count Then
'            i = i + 1
'            Debug.Print Format$(i, "000") & ": " & shp.OLEFormat.Object.Name & " => " & rngNames.Cells(i).Value
'            shp.OLEFormat.Object.Name = rngNames.Cells(i).Value
'          Else
'            Exit For 'exit because no names left
'          End If
'        End If
'      End If
'    Next
'
'  End With
'
'
'Exit Sub
'
'ErrHandler:
'  Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
'
'End Sub
'
'Private Sub DeleteBlanks()
'Dim ws As Worksheet
'
'Set ws = Worksheets("Lists")
'
'ws.Range("D2:P50").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
'
'End Sub