Hello hello,
habe versucht einen Code, der mir freundlicherweise von Gast 39624 zur Verfügung gestellt wurde, umzuändern und auf einen anderen Sachverhalt zu übertragen, leider bisher erfolglos. Habe 3 Shapegruppen, die jeweils einen Filter in eine bestimmte Spalte setzten bein Anklicken. Hier brauche ich die Ergebnisse als Schnittmenge der 3 Gruppen. Was ich bisher bekomme ist jedoch additiv (bin mir eig. gar nicht sicher was es genau ist...). Z.B. Wenn ich "External" und "Internal" für Spalte 3 und für Spalte 5 "Financial" und "Infrastructure" einstelle, ist das Ergebnis in Spalte 5 zwar korrekt, aber in Spalte 3 bekomme ich noch zusätzlich "Combination" mitaufgenommen. Den Code von Gast habe ich wie folgt angepasst (ich weiß, nicht elegant, aber ich wusste es ehrlich gesagt nicht besser):
Private myText As String
Sub RoundedRectangle_Click()
'On click filter listed categories in "Risk Category Checklist" by the text in the rounded rectangles
Dim ws As Excel.Worksheet
Dim shp As Shape
Dim CritArr()
Dim a As Integer
Dim B As Integer
Dim c 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(0, 176, 80) Then
Select Case myText
Case "Internal", "External", "Combination"
ReDim Preserve CritArr(a)
CritArr(a) = .TextFrame2.TextRange.Characters.Text
a = a + 1
Case "Financial", "Infrastructure", "Reputational", "Market"
ReDim Preserve CritArr(B)
CritArr(B) = .TextFrame2.TextRange.Characters.Text
B = B + 1
Case "Strategic", "Project-related", "Operational"
ReDim Preserve CritArr(c)
CritArr(c) = .TextFrame2.TextRange.Characters.Text
c = c + 1
End Select
End If
End With
Next shp
If a <> 0 Then
ws.Range("$A$5:$W$500").AutoFilter , Field:=3, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=3
End If
If B <> 0 Then
ws.Range("$A$5:$W$500").AutoFilter , Field:=5, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=5
End If
If c <> 0 Then
ws.Range("$A$5:$W$500").AutoFilter , Field:=10, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=10
End If
Application.ScreenUpdating = True
End Sub
Hat jemand eine Idee, woran das liegen könnte? Naja, eigentlich sollte ich bis jetzt fertig sein (also so ziemlich genau jetzt) und werde daher die Datei so wie sie ist zeigen, aber für mich und die nächste Präsi wäre es sicherlich ganz gut die erwünschten Ergebnisse vorzeigen zu können. Vielen Dank an alle und nochmal insbesondere an Gast 39624 :)
Viele Grüße,
Corina
|