Rectangle Macro over multiple lines

[LethalLeigh]

Hi all,
Fairly new to macro's so still getting the hang of them with VB.
So I have this code

Sub NIST()
'
' NIST Macro
'
'
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=10
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=9
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=9, Criteria1:= _
"<>"
Dim shp As Shape

For Each shp In ActiveSheet.Shapes

If shp.Type = msoShapeRectangle Then
If Application.Caller = shp.Name Then
shp.Fill.ForeColor.SchemeColor = 3
Else
shp.Fill.ForeColor.SchemeColor = 4
End If
End If
Next
End Sub

And many more like it, over 4 rows. Each row represents a filter group.
The goal was to select one from each row that would turn green when clicked, so in total there would be 4 green boxes from the 25.
The code here was good when each row had seperate shapes, as i could differentiate them. Now I've been asked to do this when they are all rectangles.
So each time a new box is selected, the last green box disapears.
I have used rows 3,5,7,9 for the series of rectangles, and the macros work for filtering. But could you help me with the colouring?.

Thanks

 

[shknbk2]

Welcome to the forum.

I'm not sure if this is what you are looking for, but this code will act on the shapes in the "same" row only. I stripped out the autofiltering stuff for my testing, and you can add it back in where needed. But for the coloring, the shapes I created are shown in the image, and the code is below. The code works by identifying the calling shape and then making all shapes in the same row (or at the same Top value) blue followed by making the calling shape green.

Sub NIST()
    Dim callingShp As Shape
    Dim rowShp As Shape
    
    For Each callingShp In ActiveSheet.Shapes
        If callingShp.Type = msoShapeRectangle Then
            If Application.Caller = callingShp.Name Then
                Exit For
            End If
        End If
    Next
    If callingShp Is Nothing Then Exit Sub
    For Each rowShp In ActiveSheet.Shapes
        If Abs(rowShp.Top - callingShp.Top) < 0.5 Then
            rowShp.Fill.ForeColor.SchemeColor = 4
        End If
    Next
    callingShp.Fill.ForeColor.SchemeColor = 3
End Sub

 

[LethalLeigh]

Welcome to the forum.

I'm not sure if this is what you are looking for, but this code will act on the shapes in the "same" row only. I stripped out the autofiltering stuff for my testing, and you can add it back in where needed. But for the coloring, the shapes I created are shown in the image, and the code is below. The code works by identifying the calling shape and then making all shapes in the same row (or at the same Top value) blue followed by making the calling shape green.

Sub NIST()
    Dim callingShp As Shape
    Dim rowShp As Shape
   
    For Each callingShp In ActiveSheet.Shapes
        If callingShp.Type = msoShapeRectangle Then
            If Application.Caller = callingShp.Name Then
                Exit For
            End If
        End If
    Next
    If callingShp Is Nothing Then Exit Sub
    For Each rowShp In ActiveSheet.Shapes
        If Abs(rowShp.Top - callingShp.Top) < 0.5 Then
            rowShp.Fill.ForeColor.SchemeColor = 4
        End If
    Next
    callingShp.Fill.ForeColor.SchemeColor = 3
End Sub

Works great. Thanks