Page 6 of 9 FirstFirst ... 45678 ... LastLast
Results 51 to 60 of 81

Thread: Add New Variable to Shapes

  1. #51
    Board Regular
    Join Date
    Apr 2019
    Posts
    225
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Add New Variable to Shapes

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

  2. #52
    Board Regular
    Join Date
    Apr 2019
    Posts
    225
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Add New Variable to Shapes

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


    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:
    Selection.ShapeRange.ShapeStyle = msoLineStylePreset25


    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



  3. #53
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,740
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Add New Variable to Shapes

    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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  4. #54
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,740
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Add New Variable to Shapes

    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 by Worf; Oct 15th, 2019 at 06:37 PM.
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  5. #55
    Board Regular
    Join Date
    Apr 2019
    Posts
    225
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Add New Variable to Shapes

    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...

  6. #56
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,740
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Add New Variable to Shapes

    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.
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  7. #57
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,740
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Add New Variable to Shapes

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

    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  8. #58
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,740
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Add New Variable to Shapes

    the code:

    Code:
    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
    
    
    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
    
    
    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
    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
    '*********************
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  9. #59
    Board Regular
    Join Date
    Apr 2019
    Posts
    225
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Add New Variable to Shapes

    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

  10. #60
    Board Regular
    Join Date
    Apr 2019
    Posts
    225
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Add New Variable to Shapes

    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

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •