Solved VBA To Generate Multiple Shapes Based On Number In Cell

OK, even though I’m not sure if this is what you want, I think your answer may be buried within this code.

What this does is place a bunch of small rectangles on the Auto sheet based on the values in Sheet1 Column I, S and T.

I = Count of Rectangles Per Row
S, T = Size of Rectangle (I kept this small and consistant for testing purposes)

It will place rectangles in the same row as the Column I count. e.g. if I5 = 3, there will be 3 rectangles in Row 5 on the Auto sheet. In my example, it will place the 3 rectangles in Columns I:K, 1 per column.

In order for the rectangles to be placed “neatly” in each cell, the Row height on the Auto sheet must be the default of 15 and the Column width must be the default of 8.43.

For ease of testing, I started with this on Sheet1:

        I              S        T
1
2
3       1              3        5
4       2	       3        5
5       3	       3        5
6       	       3        5
7       2	       3        5
8       5	       3        5
9       1	       3        5
10      2	       3        5
11      3	       3        5

I ended up with this (x = Rectangle)

         I       J        K        L       M  
1
2
3       x	
4       x        x	
5       x        x        x
6  
7       x        x	
8       x        x        x       x        x
9       x
10      x        x	
11      x        x        x

Here’s the code I used:

Sub RecPlacer()
Dim s As Shape
Dim r As Long, h As Long, v As Long

'****************************************************
'Clear Shapes For Testing
    Sheets("AUTO").DrawingObjects.Delete      '<----------
'****************************************************
    
'Initialize Column Placement Variable (I)
    h = 346

'Initialize Rown Placement Variable (2)
    v = 20

'Loop through Column I
     For r = 3 To Sheets("Sheet1").Cells(Rows.Count, 19).End(xlUp).Row

'Increment Row Placement Variable By One Row
      v = v + 15
         
'Add Rectangles Based On Value In Column Sheet1 Collumn I
        If Sheets("Sheet1").Cells(r, 9).Value > 0 Then
          For r_count = 1 To Sheets("Sheet1").Cells(r, 9).Value
            
'Increment Column Variable By One Column
            h = h + 48.5
        
'Place Rectangles & Text
              Set s = Sheets("AUTO").Shapes.AddShape(msoShapeRectangle, h, v, _
                      Sheets("Sheet1").Cells(r, "S"), _
                      Sheets("Sheet1").Cells(r, "T"))
               
               s.TextFrame2.TextRange.Text = _
                  Sheets("Sheet1").Cells(r, "E") & "; D=" _
               & Sheets("Sheet1").Cells(r, "F") & "; L=" _
               & Sheets("Sheet1").Cells(r, "G") & "; " _
               & Sheets("Sheet1").Cells(r, "I") & " batches; additional pcs: " _
               & Sheets("Sheet1").Cells(r, "J")
          Next
        
'Reset Column Placement Variable (I)
          h = 346
        
        End If
     Next
End Sub

How To Post Data or Code —> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03