Ich hab den Code inzwischen schon weiter angepasst.

Debuggst du wenn der Fehler auftritt oder bleibt er bei dir einfach nur dort stecken nachdem du auf eines der Shapes geklickt hast?

Du scheinst 2010 zu haben? Ich werds dann mal bei mir testen (derzeit teste ich in 2007).

Erstell für nachfolgenden Code ein eigenes Modul und gibt ihm dann den angegebenen Namen (oder gib ihn einen Namen der Wahl, hauptsache er ist etwas aussagefähig). Entferne das "alte" ModifyFilter aus dem Projekt.

'Modul: mdlCommon
Option Explicit

Public Enum ModifyAction
  mdaAdd
  mdaRemove
End Enum

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

In Modul 5 gilt es dann noch eine kleine Anpassung zu erledigen.

  Else 'Unfilter
    
    Select Case strShapeText
      Case "Internal", "External", "Combination"
        Call ModifyFilter(rngAutoFilter, 4, strShapeText, mdaRemove)
        
      Case "Financial", "Infrastructure", "Reputational", "Market"
        Call ModifyFilter(rngAutoFilter, 6, strShapeText, mdaRemove)
        
      Case "Strategic", "Project-related", "Operational"
        Call ModifyFilter(rngAutoFilter, 11, strShapeText, mdaRemove)
        
      Case Else
        Call MsgBox("Please pick a specific risk cause driver, a risk event or the effect level!")
        
    End Select
    
  End If

Damit es dann bei mir. Filter werden bei Klick um den Text des Shapes erweitert und bei erneutem Klick wird der Text wieder entfernt und alle anderen Filter beibehalten.

Gruß