Private myText As String
Sub RoundedRectangleSubcategory_Click()
Dim ws As Excel.Worksheet
Dim shp As Shape
Dim CritArr()
Dim x As Integer
Set ws = Worksheets("Risk Category Checklist")
Set shp = ActiveSheet.Shapes(Application.Caller)
ToggleShapeColor
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Shapes
With shp
If .Fill.ForeColor.RGB = RGB(255, 255, 153) Then
ReDim Preserve CritArr(x)
CritArr(x) = .TextFrame2.TextRange.Characters.Text
x = x + 1
End If
End With
Next shp
On Error GoTo Fehler
ws.Range("$A$5:$W$500").AutoFilter , Field:=7, _
Criteria1:=CritArr, Operator:=xlFilterValues
Fehler:
If Err.Number <> 0 Then ws.Range("$A$5:$W$500").AutoFilter , Field:=7
Application.ScreenUpdating = True
End Sub