VBA code to put certain text into formed rectangles

[KarolisZ7]

Hello guys,

Thanks to the forum member CSmith, I have a code which forms chart area with rectangles sized according to certain dimensions that are found in the sheet and its specific range. Currently, it looks like this:

The only thing that is left to do is to change the code slightly so that it would put certain text into these rectangles. First of, here is the code:

Public Sub CreateRectangles()
Const bY = 100, bX = 1260
  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("Skaiciavimai")
  Set rng = sht.Range("O3:X3, O4:X4, O5:X5, O6:X6, O7:X7")
  Set cht = ActiveSheet.Shapes.AddChart.Chart
  tmpStr = "Max(Sum(" & Join(Split(rng.Address, ","), "), Sum(") & "))"
  maxWidth = Application.Evaluate(tmpStr) / 5.2

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

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

  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
          .TextFrame.Characters.Text = c.Address & ": " & c.Value
          .TextFrame.Characters.Font.Color = vbBlack
      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

The same sheet also has cells (range A16:J20) that have certain variable text which should appear in the formed rectangles. Lets say cell A16 has "Product 1" written in it so I would need the code to take this text and put it in the very first rectangle, then cell A17 and its text "Product 2" to the adjecent rectangle and so on.

I would greatly appreciate the help!

 

[KarolisZ7]

Bump!