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