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