Create shape based on cell value

[Cooked_Bread13]

Hi all,

I am pretty new to VBA and have been learning a lot from reading through forum posts from other users, but have hit a snag and cant quite find the answer I need.

I have a Workbook which I have written some basic code which adjusts the position and width of Shape "Rectangle 1" based off values in cells D3 & F3. Although there is probably a far easier way to achieve what I'm aiming for, this works as expected. The code sizes the shape so that it spans across the period of two dates (snapshot below).

What I am looking to achieve now is if there is a way to loop through and create additional rectangles and set their position and width if there was additional rows of information.

I know I currently have used specific cell references like "D3" & "F3" in the VBA which is incorrect, I am just unsure what to do instead.

Any help would be much appreciated. My code example is below, with a screenshot of the sheet.

Sub SizeRectangle()

Dim cellStartLocation As Range
Dim cellEndLocation As Range
Dim cellWidth As Range

Set cellStartLocation = Worksheets(2).Range("D3")
Set cellEndLocation = Worksheets(2).Range("F3")
Set cellWidth = Worksheets(2).Range(Cells(3, cellStartLocation), Cells(3, cellEndLocation))

With ActiveSheet.Shapes("Rectangle 1")
    .Top = Cells(3, cellStartLocation).Top
    .Left = Cells(3, cellStartLocation).Left
    .Width = cellWidth.Width
End With

End Sub

 

[Micron]

You could determine the number of rows that had this 'information' and loop from the 1st row to the last, basically repeating the code parts that create the rectangles.
One way to get the number of rows with data:

Row count where data exists

I need to count the total number of rows that have data. I want to be able to use this on multiple sheets with different amounts of data rows. I cannot figure out generic code that will count the

stackoverflow.com

Then set your counter from 3 (because your 1st 2 rows don't apply) to that number. The start and stop values would always be in the same column, and your counter values would be the row (e.g. Cells(i,4) ) for the start values.

Hope that helps for now and gets you started - it's approaching 1:00 am and I'm signing off for tonight.

 

[Micron]

how about (change your sheet reference to suit and if required, change the shape height to something other than 15)

Sub sizeRectangle3()
Dim lngStart As Long, lngEnd As Long, lngwidth As Long
Dim ws As Worksheet
Dim i As Integer

Set ws = Sheets("Sheet7")
For i = 3 To ws.Range("D3").End(xlDown).Row
   lngStart = ws.Cells(i, 4)
   lngEnd = ws.Cells(i, 6)
   lngwidth = ws.Range(Cells(i, lngStart), Cells(i, lngEnd)).Width
   ws.Shapes.AddShape msoShapeRectangle, Cells(i, lngStart).Left, Cells(i, lngEnd).Top, lngwidth, 15
Next
set ws = nothing

End Sub

 

[Cooked_Bread13]

Thanks for your time Micron, That has worked perfectly.

 

[Micron]

Great! Dabbling in Excel vba seems to be paying off once in a while.
Maybe mark as solved so that others don't follow a solved thread?