Option
Explicit
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
If
ShapeExists(strShapeName, ActiveSheet)
Then
Set
objShp = ActiveSheet.Shapes(strShapeName)
strShapeText = objShp.TextFrame2.TextRange.Text
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
Const
COLOR_SECONDARY
As
Long
= &H50B000
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