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!
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Looks like U could just change these 2 lines of code...
Code:
Set rng = sht.Range("A16:J20")
.TextFrame.Characters.Text = c.Text
HTH. Dave
 
Upvote 0
Looks like U could just change these 2 lines of code...
Code:
Set rng = sht.Range("A16:J20")
.TextFrame.Characters.Text = c.Text
HTH. Dave
I believe I cannot change the range as the one I already have inserted (Set rng = sht.Range("O3:X3, O4:X4, O5:X5, O6:X6, O7:X7")) is used for the width of rectangles so if I change it to A16:J20, the whole code will no longer give me the output I need.
 
Upvote 0
OK I get it. Changing the 2nd line of code is what U need to do... the "c.text" just needs to be changed to your values from A16:J20. However, I don't get your range. U have 18 rectangles and 50 cells in the range? I think U likely could just load the range into an array and code to fill in the "c.text" part from the array but the number of rectangles would have to match the number of array positions. Dave
 
Upvote 0
OK I get it. Changing the 2nd line of code is what U need to do... the "c.text" just needs to be changed to your values from A16:J20. However, I don't get your range. U have 18 rectangles and 50 cells in the range? I think U likely could just load the range into an array and code to fill in the "c.text" part from the array but the number of rectangles would have to match the number of array positions. Dave

There are 50 cells but only 18 rectangles because some of the cells in the range might sometimes not have values in them, though there will always be 5 rows. So the number of rectangles might be anywhere from lets say 5 to max which is 50.
 
Upvote 0
Hello,

have you ever managed to solve the problem above. What is the final code?
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

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
Back
Top