VBA Filtering with Shapes Text Problem

[VBAnoob_Corina]

Hello everybody,

I have a very stubborn problem and I can't figure it out on my own. I hope somebody can help me out. In order to filter some columns in a certain worksheet, I have designed another sheet with shapes which represent the rough structure. The shapes switch colors when clicked on and also set filters. Currently the filters are set independently from each other, meaning that my result just adds the criteria up. I'm not quite sure how to describe it. But what I want is an intersecting result... This is what I wrote so far (it's not elegant at all, I'm an absolute beginner):

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:=4, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=4
End If

If B <> 0 Then
ws.Range("$A$5:$W$500").AutoFilter , Field:=6, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=6
End If

If c <> 0 Then
ws.Range("$A$5:$W$500").AutoFilter , Field:=11, Criteria1:=CritArr, Operator:=xlFilterValues
Else
ws.Range("$A$5:$W$500").AutoFilter , Field:=11
End If

Application.ScreenUpdating = True

End Sub
 
Private Sub ToggleShapeColor()
'Change shape color on click in sheet "Checklist Structure"
Dim shp As Shape
Set shp = ActiveSheet.Shapes(Application.Caller)
     
myText = shp.TextFrame2.TextRange.Characters.Text
     
    With shp
        If .Fill.ForeColor = RGB(56, 93, 138) Then
            .Fill.ForeColor.RGB = RGB(0, 176, 80)
        Else
            .Fill.ForeColor.RGB = RGB(56, 93, 138)
        End If
    End With
End Sub

I also tried playing around with the operators, but it didn't work out -.- To sum it up, I would like to preserve the criteria I already set for one column when filtering another column. Also, if you have an idea how to simplify the whole code, I'd be really grateful. Thank you very much for your support! Hope you can help...

I wish you all a great day.

Kind regards,

VBAnoob_Corina

 

[VBAnoob_Corina]

Hello again,

with some help from a very friendly person I now have a code which should actually do the trick. The problem is the run-time error I get (1004) "Application-defined or object-defined error". Could somebody please help me solve the problem? I can't even test the code, because I can't pass the error... The error occurs in when the filter should be modified, I underlined the row. Thank you very much in advance!

Option Explicit
 
Private Const C_RGB_STATE1 As Long = &H8A5D38 ' ? "&H" & Hex$(RGB(56, 93, 138))
Private Const C_RGB_STATE2 As Long = &H50B000 ' ? "&H" & Hex$(RGB(0, 176, 80))
 
Public 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 rngAutoFilter As Excel.Range
Dim shp As Excel.Shape
Dim strShapeText As String
   
Set ws = Worksheets("Risk Category Checklist")
Set rngAutoFilter = ws.Range("$A$5:$W$500")
Set shp = ActiveSheet.Shapes(Application.Caller)
strShapeText = shp.TextFrame2.TextRange.Text
   
Call ToggleShapeColor2
   
Application.ScreenUpdating = False
   
If shp.Fill.ForeColor.RGB = C_RGB_STATE2 Then
     
    'Select relevant column for filtering according to the shape's text
 Select Case strShapeText
  Case "Internal", "External", "Combination"
       Call ModifyFilter(rngAutoFilter, 4, strShapeText)
         
  Case "Financial", "Infrastructure", "Reputational", "Market"
       Call ModifyFilter(rngAutoFilter, 6, strShapeText)
         
  Case "Strategic", "Project-related", "Operational"
       Call ModifyFilter(rngAutoFilter, 11, strShapeText)
         
  Case Else
       MsgBox ("Please pick a specific risk cause driver, a risk event or the effect level!")
         
 End Select
   
Else 'Unfilter
     
 Select Case strShapeText
  Case "Internal", "External", "Combination"
        Call ModifyFilter(rngAutoFilter, 4)
       
  Case "Financial", "Infrastructure", "Reputational", "Market"
        Call ModifyFilter(rngAutoFilter, 6)
       
  Case "Strategic", "Project-related", "Operational"
        Call ModifyFilter(rngAutoFilter, 11)
       
  Case Else
        MsgBox ("Please pick a specific risk cause driver, a risk event or the effect level!")
         
  End Select
End If
   
Application.ScreenUpdating = True
   
End Sub

Public Sub ModifyFilter(Range As Excel.Range, Optional Field, Optional Value)
    
  Dim vnt As Variant
   
  If IsMissing(Field) Or IsEmpty(Field) Or IsNull(Field) Then
  ' remove/disable autofilter
    Call Range.AutoFilter
      
  ElseIf IsMissing(Value) Or IsEmpty(Value) Or IsNull(Value) Then
  ' reset field filter
    Call Range.AutoFilter(Field)
      
  Else
  ' modify field filter
      
    On Error Resume Next
    With Range.Worksheet.AutoFilter.Filters(Field)
[U]      vnt = .Criteria1[/U]
      If .Operator = xlOr Then vnt = Array(vnt, .Criteria2)
    End With
    On Error GoTo 0
      
    If Not IsEmpty(vnt) Then
      If IsArray(vnt) Then
        ReDim Preserve vnt(LBound(vnt) To UBound(vnt) + 1)
        vnt(UBound(vnt)) = Value
      Else
        vnt = Array(vnt, Value)
      End If
    Else
      vnt = Array(Value)
    End If
      
    Call Range.AutoFilter(Field, vnt, xlFilterValues)
      
  End If
    
End Sub

 

[Sektor]

Hi, Corina!
It can be that there's no filter applied to the range. You should post exact error.