VBA code to draw rectangles sized according to table data

[KarolisZ7]

Hello guys,

First of all, I believe this might be a difficult task so I would really, really appreciate someone who would take a look at this.

I have 5 individual rows of 10 data values which are widths in cm of specific items (products) (50 in total):
L11:U11
L16:U16
L21:U21
L26:U26
L31:U31

What I need is a code which would draw rectangles (one for each data value) based on the width of the item found in the corresponding cell.
Each rectangle would be 2 cm in height
For example:
The rectangle for cell L11 would be 2 cm in height and 1.7 cm in width ... as cell L11 has the value 17.0 cm in it (that should be divided by 10 as rectangle 17 cm wide is visually unnecessary)
The rectangle for cell M11 would be 2 cm in height and 1.65 cm in width ... as cell M11 has the value 16.5 cm in it (once again divided by 10)

...and so on till cell U11 and for other rows.

Additionally, rectangles would be placed in the same pattern as mentioned rows are located on excel except the rows themselves would be placed near each other.

It is also has to be said mentioned cells might sometimes have no values inserted in them. Either way, lets say there are values inserted in L11:O11, L16:O16, L21:N21 L26:N26, L31:N31 (all width sums equal to specific number of centimeters) final outcome would look like this:

 

[KarolisZ7]

I didn't like the above as all shapes are separate and not really grouped in any way, so I rewrote to this:

Public Sub CreateRectangles()
  Const bY = 200, bX = 2000
  Dim c, r, rng As Range, sht As Worksheet, sRow, cRow, sCol, cCol, cVal, maxWidth As Double, cht As Chart, tmpStr, tmpRng() As String

  Set sht = Sheets("KarolisZ7")  ' This should be the name of your sheet with the measurements...
  Set rng = sht.Range("L16:O16, L11:O11, L26:U26, L21:U21, L31:U31") ' These are the ranges you provided, and do not need to be in order...
  Set cht = sht.Shapes.AddChart.Chart
  tmpStr = "Max(Sum(" & Join(Split(rng.Address, ","), "), Sum(") & "))"
  maxWidth = Application.Evaluate(tmpStr) / 10

  cht.Shapes.SelectAll
  Selection.Delete

  cht.ChartArea.Left = bX
  cht.ChartArea.Top = bY
  cht.ChartArea.Height = Cm2Point(2 * RowsCount(rng)) + 3
  cht.ChartArea.Width = Cm2Point(maxWidth) + 2

  tmpRng = Split(rng.Address, ",")
  Call Quicksort(tmpRng, LBound(tmpRng), UBound(tmpRng))

  Set rng = sht.Range(Join(tmpRng, ", "))
  sRow = 0
  cRow = 0
  sCol = 0
  cCol = 0

  For Each r In rng.Rows
    sCol = 0
    For Each c In r.Cells
      If IsNumeric(c.Value) Then
       cVal = c.Value
      Else
        cVal = 0
      End If
      With cht.Shapes.AddShape( _
        msoShapeRectangle, _
        sCol, _
        Cm2Point(2 * sRow), _
        Cm2Point(cVal / 10), _
        Cm2Point(2))
          .Fill.Transparency = 0
          .Fill.ForeColor.RGB = RGB(238, 238, 225)
          .Line.Weight = 3
          .Line.ForeColor.RGB = RGB(112, 48, 160)
          .Name = "Cell:" & c.Address & "; Length = " & c.Value
      End With
      sCol = sCol + Cm2Point(cVal / 10)
    Next c
    sRow = sRow + 1
  Next r

  Set cht = Nothing
  Set sht = Nothing
  Set rng = Nothing
End Sub

Public Function Cm2Point(cm As Double) As Double
  Cm2Point = CSng(cm * 28.3145)
End Function

Public Sub Quicksort(values As Variant, min As Long, max As Long)

  Dim med_value As String
  Dim hi As Long
  Dim lo As Long
  Dim i As Long

  ' If the list has only 1 item, it's sorted.
  If min >= max Then Exit Sub

  ' Pick a dividing item randomly.
  i = min + Int(Rnd(max - min + 1))
  med_value = values(i)

  ' Swap the dividing item to the front of the list.
  values(i) = values(min)

  ' Separate the list into sublists.
  lo = min
  hi = max
  Do
    ' Look down from hi for a value < med_value.
    Do While values(hi) >= med_value
      hi = hi - 1
      If hi <= lo Then Exit Do
    Loop

    If hi <= lo Then
      ' The list is separated.
      values(lo) = med_value
      Exit Do
    End If

    ' Swap the lo and hi values.
    values(lo) = values(hi)

    ' Look up from lo for a value >= med_value.
    lo = lo + 1
    Do While values(lo) < med_value
      lo = lo + 1
      If lo >= hi Then Exit Do
    Loop

    If lo >= hi Then
      ' The list is separated.
      lo = hi
      values(hi) = med_value
      Exit Do
    End If

    ' Swap the lo and hi values.
    values(hi) = values(lo)
  Loop ' Loop until the list is separated.

  ' Recursively sort the sublists.
  Quicksort values, min, lo - 1
  Quicksort values, lo + 1, max

End Sub

Public Function RowsCount(rng As Range) As Long
  Dim tmp As Range, tmpRng() As String, countRows As Long
  RowsCount = 0
  tmpRng = Split(rng.Address, ",")
  For Each tmp In Range(Join(tmpRng, ", ")).Rows
    RowsCount = RowsCount + 1
  Next
End Function

It works great! Outcome of this code looks exactly like what I need! Thank you once again CSmith. While this code will already save up lots of time, is there a way or atleast an idea as to how could the code take names of products from certain cells and put them in these rectangles?

 

[CSmith]

I believe so. Start a new thread and I'm sure you will get some help Thank you for updating us glad to know it working

 

[CSmith]

Since it was only small addition try this code replacement. From this thread:

I believe so. Start a new thread and I'm sure you will get some help Thank you for updating us glad to know it working

      With cht.Shapes.AddShape( _
        msoShapeRectangle, _
        sCol, _
        Cm2Point(2 * sRow), _
        Cm2Point(cVal / 10), _
        Cm2Point(2))
          .Fill.Transparency = 0
          .Fill.ForeColor.RGB = RGB(238, 238, 225)
          .Line.Weight = 3
          .Line.ForeColor.RGB = RGB(112, 48, 160)
          .Name = "Cell:" & c.Address & "; Length = " & c.Value
          .TextFrame.Characters.Text = c.Address & ": " & c.Value
          .TextFrame.Characters.Font.Color = vbBlack
      End With

 

[KarolisZ7]

I didn't like the above as all shapes are separate and not really grouped in any way, so I rewrote to this:

Public Sub CreateRectangles()
  Const bY = 200, bX = 2000
  Dim c, r, rng As Range, sht As Worksheet, sRow, cRow, sCol, cCol, cVal, maxWidth As Double, cht As Chart, tmpStr, tmpRng() As String

  Set sht = Sheets("KarolisZ7")  ' This should be the name of your sheet with the measurements...
  Set rng = sht.Range("L16:O16, L11:O11, L26:U26, L21:U21, L31:U31") ' These are the ranges you provided, and do not need to be in order...
  Set cht = sht.Shapes.AddChart.Chart
  tmpStr = "Max(Sum(" & Join(Split(rng.Address, ","), "), Sum(") & "))"
  maxWidth = Application.Evaluate(tmpStr) / 10

  cht.Shapes.SelectAll
  Selection.Delete

  cht.ChartArea.Left = bX
  cht.ChartArea.Top = bY
  cht.ChartArea.Height = Cm2Point(2 * RowsCount(rng)) + 3
  cht.ChartArea.Width = Cm2Point(maxWidth) + 2

  tmpRng = Split(rng.Address, ",")
  Call Quicksort(tmpRng, LBound(tmpRng), UBound(tmpRng))

  Set rng = sht.Range(Join(tmpRng, ", "))
  sRow = 0
  cRow = 0
  sCol = 0
  cCol = 0

  For Each r In rng.Rows
    sCol = 0
    For Each c In r.Cells
      If IsNumeric(c.Value) Then
       cVal = c.Value
      Else
        cVal = 0
      End If
      With cht.Shapes.AddShape( _
        msoShapeRectangle, _
        sCol, _
        Cm2Point(2 * sRow), _
        Cm2Point(cVal / 10), _
        Cm2Point(2))
          .Fill.Transparency = 0
          .Fill.ForeColor.RGB = RGB(238, 238, 225)
          .Line.Weight = 3
          .Line.ForeColor.RGB = RGB(112, 48, 160)
          .Name = "Cell:" & c.Address & "; Length = " & c.Value
      End With
      sCol = sCol + Cm2Point(cVal / 10)
    Next c
    sRow = sRow + 1
  Next r

  Set cht = Nothing
  Set sht = Nothing
  Set rng = Nothing
End Sub

Public Function Cm2Point(cm As Double) As Double
  Cm2Point = CSng(cm * 28.3145)
End Function

Public Sub Quicksort(values As Variant, min As Long, max As Long)

  Dim med_value As String
  Dim hi As Long
  Dim lo As Long
  Dim i As Long

  ' If the list has only 1 item, it's sorted.
  If min >= max Then Exit Sub

  ' Pick a dividing item randomly.
  i = min + Int(Rnd(max - min + 1))
  med_value = values(i)

  ' Swap the dividing item to the front of the list.
  values(i) = values(min)

  ' Separate the list into sublists.
  lo = min
  hi = max
  Do
    ' Look down from hi for a value < med_value.
    Do While values(hi) >= med_value
      hi = hi - 1
      If hi <= lo Then Exit Do
    Loop

    If hi <= lo Then
      ' The list is separated.
      values(lo) = med_value
      Exit Do
    End If

    ' Swap the lo and hi values.
    values(lo) = values(hi)

    ' Look up from lo for a value >= med_value.
    lo = lo + 1
    Do While values(lo) < med_value
      lo = lo + 1
      If lo >= hi Then Exit Do
    Loop

    If lo >= hi Then
      ' The list is separated.
      lo = hi
      values(hi) = med_value
      Exit Do
    End If

    ' Swap the lo and hi values.
    values(hi) = values(lo)
  Loop ' Loop until the list is separated.

  ' Recursively sort the sublists.
  Quicksort values, min, lo - 1
  Quicksort values, lo + 1, max

End Sub

Public Function RowsCount(rng As Range) As Long
  Dim tmp As Range, tmpRng() As String, countRows As Long
  RowsCount = 0
  tmpRng = Split(rng.Address, ",")
  For Each tmp In Range(Join(tmpRng, ", ")).Rows
    RowsCount = RowsCount + 1
  Next
End Function

Hello again CSmith, so I have been playing with the code for a while and I recently noticed that whenever I want to the code to generate these rectangles in the same sheet, it seems that it randomly deletes some of the cells in that worksheet. I think this can be solved by generating all those rectangles in a separate sheet that is dedicated to the visual representation, though I do not exactly know how this can be done. Current code uses sheet "KarolisZ7" as a place to generate rectangles. Let's say I want the code to take the measurements from sheet "KarolisZ7" and generate them in the sheet "KarolisZ7.2" at specific coordinates. Can this be done? Thank you once again for your effort

 

[CSmith]

Hello again CSmith, so I have been playing with the code for a while and I recently noticed that whenever I want to the code to generate these rectangles in the same sheet, it seems that it randomly deletes some of the cells in that worksheet. I think this can be solved by generating all those rectangles in a separate sheet that is dedicated to the visual representation, though I do not exactly know how this can be done. Current code uses sheet "KarolisZ7" as a place to generate rectangles. Let's say I want the code to take the measurements from sheet "KarolisZ7" and generate them in the sheet "KarolisZ7.2" at specific coordinates. Can this be done? Thank you once again for your effort

This probably because of the horrible Selection.Delete...

Use this code:

    Do While cht.Shapes.Count > 0
      cht.Shapes(cht.Shapes.Count).Delete
      DoEvents
    Loop

instead of:

  cht.Shapes.SelectAll
  Selection.Delete