VBA code to put certain text into formed rectangles

KarolisZ7

New Member
Joined
Mar 5, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
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:
current.PNG

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:
VBA 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!
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

Watch MrExcel Video

Forum statistics

Threads
1,126,940
Messages
5,621,727
Members
415,853
Latest member
Newlife72

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top