Add New Variable to Shapes

Doflamingo

Board Regular
On the chart that goes from bottom to top

I add a new variable in the column E with the value ''O'', where the objective is to outline the big shape related in Red, exemple if the cell E2 or E15 have the value ''O'' the big shapes related to them are outlined in Red, else no outline

I found this

Code:
   With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
[COLOR=#333333]

[/COLOR]
But I currently don't know how to locate those lines in the code you gave me for the chart that goes from bottom to top
 

Doflamingo

Board Regular
On the same chart that goes from bottom to top

Here is the code for a macro to link by horizontal connectors 2 shapes that were not linked previously by the macro ''orga''

Code:
[/COLOR]Sub liensSup()   
   Set forga = ActiveSheet
   Set f = ActiveSheet
   For Each s In forga.Shapes
    If Right(s.Name, 4) = "Lien" Then s.Delete
   Next
    Tbl = f.Range("j2:l" & f.[g65000].End(xlUp).Row).Value
   n = UBound(Tbl)
   For i = 1 To UBound(Tbl)
        shape1 = Tbl(i, 1)
        shape2 = Tbl(i, 2)
        If Tbl(i, 3) = "Fleche" Then
           forga.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100).Name = shape1 & shape2 & "Lien"
           forga.Shapes(shape1 & shape2 & "Lien").Line.BeginArrowheadStyle = msoArrowheadTriangle
           forga.Shapes(shape1 & shape2 & "Lien").Line.EndArrowheadStyle = msoArrowheadTriangle
        Else
           forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = shape1 & shape2 & "Lien"
           forga.Shapes(shape1 & shape2 & "Lien").Line.ForeColor.SchemeColor = 22
        End If
        forga.Shapes(shape1 & shape2 & "Lien").ConnectorFormat.BeginConnect forga.Shapes(shape1), 4
        forga.Shapes(shape1 & shape2 & "Lien").ConnectorFormat.EndConnect forga.Shapes(shape2), 2
        forga.Shapes(shape1 & shape2 & "Lien").Line.DashStyle = msoLineDash
    Next i
End Sub






[COLOR=#333333]
There are two types of connectors and it only work if the shapes already exist. They are located in the column J and K that represent the shape 1 and Shape 2 and in the column L it represent the horizontal connector between shape 1 and shape 2

So what I try to do is for the macro orga that create the chart from bottom to top, I add 3 new variables from column F, G and H.

For instance in the column F, if cell F2 and cell F8 they have the values ''C'' into them, I would like the connectors be black and dotted

Code for VBA

Code:
[/COLOR]Selection.ShapeRange.ShapeStyle = msoLineStylePreset25[COLOR=#333333]
For instance in the column G, if cell G2 and cell G8 they have the values ''S'' into them, I would like the connectors be just black

and finally
For instance in the column H, if cell H2 and cell H8 they have the values ''C-S'' into them, I would like the connectors be orange and dotted

VBA code

Code:
Selection.ShapeRange.ShapeStyle = msoLineStylePreset24
I try to adapt it to the code ''orga'' you kindly gave me with those new variables and inspire me with the code to link 2 shapes above to find the right solution... if you have any idea or suggestion ... I would happily take it

Many thanks for what you have done so far to help me

Kind regards


 

Worf

Well-known Member
This version uses a single worksheet, with the table starting at cell A1. As the code works by deleting rows, ranges are being moved around.

Code:
Sub main()  ' run me
Dim arr(), i%
arr = Range([a1].CurrentRegion.Address)                 ' save original table
[ca:ce].ClearContents
Adjust
CreateDiagram ActiveSheet
[a:o].ClearContents
[a1].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr ' original table
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(i).TopLeftCell = [a1] Then ActiveSheet.Shapes(i).Delete
Next
On Error GoTo 0
End Sub


Sub Adjust()
Dim lr%, i%
For i = 1 To ActiveSheet.Shapes.Count
    ActiveSheet.Shapes(1).Delete
Next
[k:ad].ClearContents
lr = Range("a" & Rows.Count).End(xlUp).Row
[k1] = "Seq": [L1] = "code1": [m1] = "code2"
[L2] = [b2]: [n1] = "info": [o1] = "info2"
[m2] = [b2]: [k2] = 2: [n2] = 0.01
[o2] = "desc0"
Range("a2:a" & lr).Copy [L3]
Range("b2:b" & lr).Copy [m3]
Range("c2:c" & lr).Copy [o3]
Range("d2:d" & lr).Copy [n3]
Range("k3:k" & lr + 1).Formula = "=row()"
[a:d].ClearContents
[k1].CurrentRegion.Copy [a1]                    ' adjusted table
[L2].Interior.Color = RGB(35, 70, 90)
[k1].CurrentRegion.Copy [z100]
End Sub


Sub CreateDiagram(Source As Worksheet)
Dim oSALayout As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, oshp As Shape, Line%, _
i%, r As Range, PID$, mn, mx, ws As Worksheet, crar(), c%, ad, v, t, s As ShapeRange, boss
c = 1
ReDim crar(1 To c)
Set ws = ActiveSheet
For i = 1 To ws.Shapes.Count
    ws.Shapes(1).Delete
Next
Set oSALayout = Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(oSALayout)
oshp.Top = [a50].Top
Set QNodes = oshp.SmartArt.AllNodes
For i = 1 To 5
    oshp.SmartArt.AllNodes(1).Delete        ' initial nodes
Next
Line = 2                                     ' look for roots
boss = [b2]
Do While Source.Cells(Line, 1) <> ""
    If Source.Cells(Line, 2) = Source.Cells(Line, 3) Then
        Set QNode = oshp.SmartArt.AllNodes.Add
        QNode.TextFrame2.TextRange.Text = Source.Cells(Line, 2)
        PID = Source.Cells(Line, 2)         ' parent node
        Source.Rows(Line).Delete
        AddChildNodes QNode, Source, PID
    Else
        Line = Line + 1
    End If
Loop
oshp.SmartArt.AllNodes(1).TextFrame2.TextRange.Text = boss
oshp.Width = 1000
oshp.Height = 700
oshp.Select
CommandBars.ExecuteMso ("SmartArtConvertToShapes")
Selection.Ungroup
Set r = ws.[a2]
On Error Resume Next
For i = 1 To ws.Shapes.Count
    r = ws.Shapes(i).Height
    Set r = r.Offset(1)
Next
mn = WorksheetFunction.Min([a:a])
mx = WorksheetFunction.Max([a:a])
For i = ws.Shapes.Count To 1 Step -1
    If ws.Shapes(i).Height = mn Then ws.Shapes(i).Delete
    If ws.Shapes(i).Height = mx Then
        crar(c) = ws.Shapes(i).Name
        c = c + 1
        ReDim Preserve crar(1 To c)
    End If
Next
On Error GoTo 0
For i = LBound(crar) To UBound(crar)
    If Len(crar(i)) Then
        v = Split(ws.Shapes(crar(i)).TextFrame2.TextRange.Text, vbLf)(0)
        Set r = Range("aa:aa").Find(v, [aa1], xlValues, 1)
        ad = r.Offset(, 2)
        ws.Shapes(crar(i)).Fill.ForeColor.RGB = r.Interior.Color
        Set s = ws.Shapes.Range(Array(crar(i)))
        s.TextFrame2.TextRange.Font.Bold = msoTrue
        s.TextFrame2.TextRange.Font.Name = "+mj-lt"
        ws.Shapes.AddShape(62, 10, 10, ws.Shapes(crar(i)).Width / 2.5, ws.Shapes(crar(i)).Height / 3).Name = _
        ws.Shapes(crar(i)).Name & "aux"
        With ws.Shapes(ws.Shapes(crar(i)).Name & "aux")
            .Left = ws.Shapes(crar(i)).Left
            .Top = ws.Shapes(crar(i)).Top + ws.Shapes(crar(i)).Height + 2
            .Line.ForeColor.SchemeColor = 1
            .Fill.Visible = msoFalse
            .TextFrame.Characters.Text = FormatPercent(ad, 0, vbTrue, vbFalse, vbUseDefault)
            .TextFrame.Characters(1, Len(ad)).Font.Size = 9
            .TextFrame.Characters(1, Len(ad)).Font.ColorIndex = 0
            .TextFrame.Characters(1, Len(ad)).Font.Bold = 1
            If ad = 0 Then .TextFrame.Characters.Text = "0%"
        End With
    End If
Next
End Sub


Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID$)
Dim Line%, Found As Boolean, ParNode As SmartArtNode, CurPid$, ad
Line = 2
Found = False                           'nothing found yet
Do While Source.Cells(Line, 1) <> ""
    If Source.Cells(Line, 3) = PID Then
        Set ParNode = QNode
        Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
        QNode.TextFrame2.TextRange.Text = Cells(Line, 2) & vbLf & Cells(Line, 5)
        CurPid = Source.Cells(Line, 2)  ' current parent node
        If Not Found Then Found = True  'something was found
        Source.Rows(Line).Delete
        AddChildNodes QNode, Source, CurPid
        Set QNode = ParNode
        ElseIf Found Then               'it's sorted, nothing else can be found
        Exit Do
    Else
        Line = Line + 1
    End If
Loop
End Sub
 

Worf

Well-known Member
The chart that goes from bottom to top does not centre the offspring relative to its parent. Would you like to use the top to bottom template, which does the centring, or shall we continue with the current layout?

The result would be a centred bottom to top chart.
 
Last edited:

Doflamingo

Board Regular
Hello @Worf

Many thanks for your reply and your help on the topic, I have no more questions on the chart that goes from top to bottom.

About the chart that goes from bottom to top, is the top to bottom template will allow me to add the new variables in the column E, F, G and H about the color of connectors and outline of the shapes ? Because if not...I would prefer keep working on the current layout...
 

Worf

Well-known Member
The customizations you mention can probably be implemented on the top to bottom template, which at the end will become a bottom to top chart.
I will be back soon.
 

Worf

Well-known Member
Here is the bottom to top chart with the outline feature. As before, the table starts at cell A1.

 

Worf

Well-known Member
the code:

Code:
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub main()  ' run me
Dim arr(), i%, t
arr = Range([a1].CurrentRegion.Address)                 ' save original table
[ca:ce].ClearContents
Adjust
CreateDiagram ActiveSheet
[a:p].ClearContents
[a1].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr ' original table
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(i).TopLeftCell = [a1] Then ActiveSheet.Shapes(i).Delete
    t = ActiveSheet.Shapes(i).TextFrame2.TextRange.Text
    If Len(t) And Not t Like "*%*" Then ActiveSheet.Shapes(i).IncrementRotation 180
Next
On Error GoTo 0
End Sub

[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Adjust()
Dim lr%, i%
For i = 1 To ActiveSheet.Shapes.Count
    ActiveSheet.Shapes(1).Delete
Next
[k:ae].ClearContents
lr = Range("a" & Rows.Count).End(xlUp).Row
[k1] = "Seq": [L1] = "code1": [m1] = "code2"
[L2] = [b2]: [n1] = "info": [o1] = "info2": [p1] = "outline"
[m2] = [b2]: [k2] = 2: [n2] = 0.01: [o2] = "desc0"
Range("a2:a" & lr).Copy [L3]
Range("b2:b" & lr).Copy [m3]
Range("c2:c" & lr).Copy [o3]
Range("d2:d" & lr).Copy [n3]
Range("e2:e" & lr).Copy [p3]
Range("k3:k" & lr + 1).Formula = "=row()"
[a:e].ClearContents
[k1].CurrentRegion.Copy [a1]                    ' adjusted table
[L2].Interior.Color = RGB(35, 70, 90)
[k1].CurrentRegion.Copy [z100]
End Sub

[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub CreateDiagram(Source As Worksheet)
Dim sal As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, oshp As Shape, L%, _
i%, r As Range, PID$, mn, mx, ws As Worksheet, crar(), c%, ad, v, t, s As ShapeRange, boss
c = 1
ReDim crar(1 To c)
Set ws = ActiveSheet
For i = 1 To ws.Shapes.Count
    ws.Shapes(1).Delete
Next
Set sal = Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(sal)
oshp.Top = [a50].Top
Set QNodes = oshp.SmartArt.AllNodes
For i = 1 To 5
    oshp.SmartArt.AllNodes(1).Delete        ' initial nodes
Next
L = 2                                     ' look for roots
boss = [b2]
Do While Source.Cells(L, 1) <> ""
    If Source.Cells(L, 2) = Source.Cells(L, 3) Then
        Set QNode = oshp.SmartArt.AllNodes.Add
        QNode.TextFrame2.TextRange.Text = Source.Cells(L, 2)
        PID = Source.Cells(L, 2)         ' parent node
        Source.Rows(L).Delete
        AddChildNodes QNode, Source, PID
    Else
        L = L + 1
    End If
Loop
oshp.SmartArt.AllNodes(1).TextFrame2.TextRange.Text = boss
oshp.Width = 1000
oshp.Height = 700
oshp.Select
CommandBars.ExecuteMso ("SmartArtConvertToShapes")
Selection.ShapeRange.IncrementRotation 180
Selection.Ungroup
Set r = ws.[a2]
On Error Resume Next
For i = 1 To ws.Shapes.Count
    r = ws.Shapes(i).Height
    Set r = r.Offset(1)
Next
mn = WorksheetFunction.Min([a:a])
mx = WorksheetFunction.Max([a:a])
For i = ws.Shapes.Count To 1 Step -1
    If ws.Shapes(i).Height = mn Then ws.Shapes(i).Delete
    If ws.Shapes(i).Height = mx Then
        crar(c) = ws.Shapes(i).Name
        c = c + 1
        ReDim Preserve crar(1 To c)
    End If
Next
On Error GoTo 0
For i = LBound(crar) To UBound(crar)
    If Len(crar(i)) Then
        v = Split(ws.Shapes(crar(i)).TextFrame2.TextRange.Text, vbLf)(0)
        Set r = Range("aa:aa").Find(v, [aa1], xlValues, 1)
        ad = r.Offset(, 2)
        ws.Shapes(crar(i)).Fill.ForeColor.RGB = r.Interior.Color
        Set s = ws.Shapes.Range(Array(crar(i)))
        s.TextFrame2.TextRange.Font.Bold = msoTrue
        s.TextFrame2.TextRange.Font.Name = "+mj-lt"
        If r.Offset(, 4) = "O" Then                 ' outline
            With s.Line
                .Weight = 4
                .Visible = msoTrue
                .ForeColor.RGB = RGB(200, 25, 55)
                .Transparency = 0.1
            End With
        End If
        ws.Shapes.AddShape(62, 10, 10, ws.Shapes(crar(i)).Width / 2.5, ws.Shapes(crar(i)).Height / 3).Name = _
        ws.Shapes(crar(i)).Name & "aux"
        With ws.Shapes(ws.Shapes(crar(i)).Name & "aux")
            .Left = ws.Shapes(crar(i)).Left
            .Top = ws.Shapes(crar(i)).Top + ws.Shapes(crar(i)).Height
            .Line.ForeColor.SchemeColor = 1
            .Line.Transparency = 1
            .Fill.Visible = msoFalse
            .TextFrame.Characters.Text = FormatPercent(ad, 0, vbTrue, vbFalse, vbUseDefault)
            .TextFrame.Characters(1, Len(ad)).Font.Size = 9
            .TextFrame.Characters(1, Len(ad)).Font.ColorIndex = 0
            .TextFrame.Characters(1, Len(ad)).Font.Bold = 1
            If ad = 0 Then .TextFrame.Characters.Text = "0%"
        End With
    End If
Next
End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID$)
Dim L%, Found As Boolean, ParNode As SmartArtNode, CurPid$, ad
L = 2
Found = False                           'nothing found yet
Do While Source.Cells(L, 1) <> ""
    If Source.Cells(L, 3) = PID Then
        Set ParNode = QNode
        Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
        QNode.TextFrame2.TextRange.Text = Cells(L, 2) & vbLf & Cells(L, 5)
        CurPid = Source.Cells(L, 2)  ' current parent node
        If Not Found Then Found = True  'something was found
        Source.Rows(L).Delete
        AddChildNodes QNode, Source, CurPid
        Set QNode = ParNode
        ElseIf Found Then               'it's sorted, nothing else can be found
        Exit Do
    Else
        L = L + 1
    End If
Loop
End Sub
'*********************[/FONT]
 

Doflamingo

Board Regular
Hello @Worf

Many thanks for your reply on the chart

I really wanted to thank you personally and I send you a personnal message in your inbox

I just saw what you have done with smartart, and I had few questions

- Is it possible to increase by *1.5 the height of the connectors ?

I though it was that variable or this one
Code:
L = 3
Code:
oshp.Height = 700
but actually not, it is linked to the size of the shape

-Is it possible to keep the colors given to shapes in column A , because when the macro is launched, it erases the colors ...and at each time i have to give to each cell the colors they had before the macro was launched

-Is it possible to have no color and no data in the column AA to AE ? It seems the data from column A to E are exported to column AA to EE

Many thanks for your time and your help again

Kind regards
 

Doflamingo

Board Regular
Hi @Worf

I hope you are well :). I just wanted you to know i have found the solution to my previous questions:

-performed to have empty cells with no color in AA to EE
-Colors kept in the column AA

Just looking for the lines of code that would allow me to increase a little the height of the connectors


Kind regards
 

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top