Hi,

ich hake mich hier mal eben ein um auf eine ähnliche Aufgabenstellung hinzuweisen.

Für dich dürfte sich daraus etwas in dieser Art ergeben (ungetestet):

Option Explicit
 
'Makro welches einem Shape zugewiesen werden kann
Public Sub Shape_OnAction()
   
  Dim objShp As Excel.Shape
  Dim strShapeName As String
  Dim strShapeText As String
   
  Select Case TypeName(Application.Caller)
    Case "String"
      strShapeName = Application.Caller
    Case Else
      Exit Sub
  End Select
  
  'prüfen ob der ShapeName wirklich vorhanden ist
  ' man vermeidet so einen Laufzeitfehler bei >Shapes(strShapeName)<
  If ShapeExists(strShapeName, ActiveSheet) Then
    
    Set objShp = ActiveSheet.Shapes(strShapeName)
    
    strShapeText = objShp.TextFrame2.TextRange.Text
    
'    Call MsgBox("Shape = '" & strShapeName & "'" & vbNewLine & _
'                "Text = '" & strShapeText & "'")
    
    With ThisWorkbook.Worksheets("Sheet3")
      If .FilterMode Then
        .Range("$A$5:$T$500").AutoFilter , Field:=4
      Else
        .Range("$A$5:$T$500").AutoFilter , Field:=4, Criteria1:=strShapeText
      End If
    End With
    
    Call ToggleShapeColor(objShp)
    
  Else
    Call MsgBox("Shape '" & strShapeName & "' wurde im aktiven Blatt nicht gefunden.", _
                vbExclamation)
  End If
  
End Sub

Private Sub ToggleShapeColor(Shape As Excel.Shape)
  
  Const COLOR_PRIMARY As Long = &H8A5D38  'RGB(56, 93, 138)
  Const COLOR_SECONDARY As Long = &H50B000  'RGB(0, 176, 80)
  
  If Shape Is Nothing Then Exit Sub
  
  With Shape.Fill.ForeColor
    If .RGB = COLOR_PRIMARY Then
      .RGB = COLOR_SECONDARY
    Else
      .RGB = COLOR_PRIMARY
    End If
  End With
  
End Sub

Public Function ShapeExists(Name As String, Optional Sheet As Object) As Boolean
  On Error Resume Next
  If Sheet Is Nothing Then
    ShapeExists = (ActiveSheet.Shapes(Name).Name <> "")
  Else
    ShapeExists = (Sheet.Shapes(Name).Name <> "")
  End If
End Function

Gruß