Hallo Zusammen,

ich versuche in Excel mit VBA ein Organigramm über eine Liste zu erstellen. Dazu nutze ich SmartArts. Das erstellen des Organigramm funktioniert soweit sehr gut. Nur habe ich das Problem, dass ich noch keine Lösung für folgendes Thema habe:

- die Schriftgröße gebe ich mit 8 vor.

- der Text soll keinen automatischen Umbruch haben

- die Größe des Kastens soll an die Textgröße angepasst werden für jede Person im Chart.

Bei dem Zugriff auf AutoSize bekomme ich immer einen Laufzeit Fehler: Laufzeitfehler '-2147024809 (80070057)' Der angegebene Wert ist außerhalb des zulässigen Bereichs.

With QNode.Shapes(1).TextFrame2
        .TextRange.Font.Fill.ForeColor.RGB = vbBlack
        .WordWrap = msoFalse
        .AutoSize = msoAutoSizeShapeToFitText -> Fehler!!!

Vielen Dank schon mal für die Unterstützung!!!

Gruß

Mathias

Dim sTabHCPlanning As String
Dim sTabOrgChart As String

Private Sub BtnUpdateOrgChart_Click()
    createOrgChart
End Sub


Sub createOrgChart()

    Dim shp As Shape
    Dim ogSALayout As SmartArtLayout
    Dim ogShp As Shape
    Dim QNodes As SmartArtNodes
    Dim QNode As SmartArtNode
    Dim t As Long
    Dim i As Long
    Dim Code As String
    
    sTabOrgChart = "Organization Chart"
    sTabHCPlanning = "HC Planning"
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For Each shp In Worksheets(sTabOrgChart).Shapes
        If shp.Type = msoSmartArt Then
            shp.Delete
        End If
    Next shp

    Set ogSALayout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
    Set ogShp = Worksheets(sTabOrgChart).Shapes.AddSmartArt(ogSALayout, 50, 50) ', 1200, 1200)
    Set QNodes = ogShp.SmartArt.AllNodes
    t = QNodes.Count

    ' Delete all nodes except one
    For i = 2 To t
        ogShp.SmartArt.Nodes(1).Delete
    Next i

    ' Set root node properties
    Set QNode = QNodes(1)
    With QNode.Shapes(1).TextFrame2
        .TextRange.Font.Fill.ForeColor.RGB = vbBlack
        .WordWrap = msoFalse
        .AutoSize = msoAutoSizeShapeToFitText
        .MarginBottom = 10
        .MarginLeft = 10
        .MarginRight = 10
        .MarginTop = 10
        .TextRange.Font.Size = 8
        .TextRange.Text = Worksheets(sTabHCPlanning).Range("D4").Value & Chr(10) & Worksheets(sTabHCPlanning).Range("C4").Value
    End With
    
    QNode.Shapes(1).Fill.ForeColor.RGB = RGB(221, 221, 221)
    
    Code = Worksheets(sTabHCPlanning).Range("A4").Value

    ' Recursively add children nodes
    Call AddChildren(QNode, Code)
             
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

Sub AddChildren(ByVal QParent As SmartArtNode, ByVal Code As String)
    Dim Level As Long
    Dim v As Variant
    Dim r As Long
    Dim QChild As SmartArtNode
    ' Dissect the code
    v = Split(Code, ".")
    ' Next level
    Level = UBound(v) + 2
    ' Loop through the rows
    For r = 2 To 1000 'Worksheets(sTabHCPlanning).Range("A2").End(xlDown).Row
        ' Look for correct level and code
        If Worksheets(sTabHCPlanning).Range("E" & r).Value = Level And Worksheets(sTabHCPlanning).Range("A" & r).Value Like Code & ".*" Then
            ' Create new node
            Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
            ' Set node properties
            With QChild.Shapes(1).TextFrame2
                .TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                .TextRange.Font.Fill.ForeColor.RGB = vbBlack
                .WordWrap = msoFalse
                .MarginBottom = 10
                .MarginLeft = 10
                .MarginRight = 10
                .MarginTop = 10
                .TextRange.Font.Size = 8
            End With
            If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "RETIRED" Then
                QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 80, 80)
                QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - RETIRED" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
            Else
                If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "NEW" Then
                    QChild.Shapes(1).Fill.ForeColor.RGB = RGB(51, 204, 51)
                    QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - NEW" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                Else
                    If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "SUBSTITUDE" Then
                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(51, 204, 51)
                        QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - SUBSTITUDE" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                    Else
                        If StrConv(Trim(Worksheets(sTabHCPlanning).Range("G" & r).Value), vbUpperCase) = "DEPARTMENT" Then
                            QChild.Shapes(1).Line.ForeColor.RGB = RGB(255, 51, 0)
                            QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                            QChild.Shapes(1).TextFrame2.TextRange.Font.Bold = msoCTrue
                            QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " [" & Worksheets(sTabHCPlanning).Range("D" & (r - 1)).Value & "]" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                        Else
                            If StrConv(Trim(Worksheets(sTabHCPlanning).Range("G" & r).Value), vbUpperCase) = "TEAM" Then
                                QChild.Shapes(1).Line.ForeColor.RGB = RGB(51, 204, 51)
                                QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                                QChild.Shapes(1).TextFrame2.TextRange.Font.Bold = msoCTrue
                                QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " [" & Worksheets(sTabHCPlanning).Range("D" & (r - 1)).Value & "]" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                            Else
                                If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "OPEN" Then
                                    QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 153, 0)
                                    QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - OPEN" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                                Else
                                    If StrConv(Trim(Worksheets(sTabHCPlanning).Range("F" & r).Value), vbUpperCase) = "RESIGNED" Then
                                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(255, 80, 80)
                                        QChild.Shapes(1).TextFrame2.TextRange.Text = Worksheets(sTabHCPlanning).Range("D" & r).Value & " - RESIGNED" & Chr(10) & Worksheets(sTabHCPlanning).Range("C" & r).Value
                                    Else
                                        QChild.Shapes(1).Fill.ForeColor.RGB = RGB(228, 228, 228)
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
            
            ' Recursion!
            Call AddChildren(QChild, Worksheets(sTabHCPlanning).Range("A" & r).Value)
        End If
    Next r
End Sub