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