Loop through a row until blank - vba

Question

I have the code below that does the following.
It finds the text “EE Only” in column A and records the row number.
It then adds four rectangles with the first one in the recorded row number and the other three in the three rows below.
It then formats the rectangles with no fill and a black border.
I have dim c as Integer and c = 2. I then use that as the column. So far everything is working as it should. The problem I’m having is that I need the column number to increase by one for every column after B that has something in row 3. In other words; the first set of shapes will always be in column B. After that if there is something in C3 then I need the column number to be increase by 1 and the shapes added to column C. If something is in D3 increase c by 1 and add shapes to column D and so forth. The first time row 3 is blank the loop would stop.
I’ve tried a couple of different things and I’m at a completely loss. The other issue I’m having is, if I run the code with c = 2 the shapes are formatted properly. If I then leave those shapes and manually change to c = 3 and run the code again, the new set of shapes have a blue fill. Again, tried everything I could find and nothing works.
Sub AddShapes()
Const TextToFind As String = "EE Only"
Dim ws As Worksheet
Dim RowNum As Range
Dim SSLeft As Double
Dim SSTop As Double
Dim SS As Range
Set ws = ActiveSheet
Dim c As Integer
c = 2
Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
Set SS = Cells(RowNum.Row, c)
SSLeft = Cells(RowNum.Row, c).Left + (Cells(RowNum.Row, c).Width) / 4
'Add four rectangles
Dim y As Integer
For y = 0 To 3
SSTop = Cells(RowNum.Row + y, c).Top + ((Cells(RowNum.Row + y, c).Height) / 2) - 5
Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
Next
'Format them
ws.DrawingObjects.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
End Sub

Answer 1

I wasn't 100% sure about your requirements, but here's my best interpretation of it. Not I defined a new subroutine for the rectangles section, see comments for details
Sub AddShapes()
Const TextToFind As String = "EE Only"
Dim ws As Worksheet
Dim RowNum As Range
Set ws = ActiveSheet
Dim c As Integer
c = 2
Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
Call Rectangles(RowNum.row, c, ws) ' call the rectangles function for our first instance
c = c+1 ' increment the column by one so we're not on the same column
Do While Not IsEmpty(Cells(3,c).Value) 'Loop through each column until the 3rd row is empty
Call Rectangles(3,c,ws) ' call our rectangles function on the 3rd row in the current column (c)
c=c+1 ' increment the column
Loop
End Sub
Sub Rectangles(row As Integer, c As Integer, ws As Worksheet) ' we define a separate sub to draw the rectangles so that we can call it again and again
Dim SSLeft As Double
Dim SSTop As Double
Dim SS As Range
Set SS = Cells(row, c)
SSLeft = Cells(row, c).Left + (Cells(row, c).Width) / 4
'Add four rectangles
Dim y As Integer
For y = 0 To 3
SSTop = Cells(row + y, c).Top + ((Cells(row + y, c).Height) / 2) - 5
Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
Next
'Format them
ws.DrawingObjects.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
End Sub