Daten mit VBA visualisieren (Organigramm)

[ExcelFoley69]

Liebe Community,
ich würde gerne aus einer vorsortierten Liste ein Organigramm erzeugen, in dem die Position und der Name enthalten ist, welches sich dann nach Hierarchien gliedert. Sprich der Chef ganz oben, darunter die Abteilungsleiter usw.
Manuell kann ich das ganze erzeugen, jedoch updatet sich die Liste ab und zu und dann müsste ich immer alles neu machen. Deswegen würde ich gerne ein VBA Skript dazu schreiben.
Jedoch fehlt mir dazu ein Ansatz. Ich habe bereits probiert mit dem Makro Rekorder ein Organigramm zu erzeugen, jedoch hat das nicht funktioniert. Ich kann auch kein Visio Ad-on zu meinem Excel hinzufügen. Ich würde es gerne rein in Excel machen. 

Code:

Sub Filtern()
    Sheets("Hilfstabelle").Select
    Cells.Select
    Selection.ClearContents
    Sheets("Abteilung").Range("A1:F95").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Abteilung").Range("J1:J2"), CopyToRange:=Sheets("Hilfstabelle").Range("A1") _
        , Unique:=False
       


If Sheets("Abteilung").Range("J2").Value = "XXX" Then
 
'
' Sortieren Makro
'

'
    Range("A1:F1").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Hilfstabelle").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Hilfstabelle").Sort.SortFields.Add Key:=Range( _
        "B2:B200"), SortOn:=xlSortOnValues, CustomOrder:="PL, CE, SysFo, E/E TPL", DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Hilfstabelle").Sort
        .SetRange Range("A1:F200")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End If
End Sub

Das ist mein Code der mir die fertige, nach Hierarchien sortierte Tabelle liefert. 
Im Organigramm wäre PL an erster Stelle und darunter auf gleicher Ebene alle anderen Positionen.
Würde mich sehr über einen Ansatz oder Tipps freuen,
LG Excel :17:

[Fennek]

Hallo,

diese "SmartArt" sind sehr unangenehm zu programmieren:

- die Struktur zu ändern "geht nicht"
- Namen zu ändert geht

mfg

[ExcelFoley69]

Danke dir,
könntest du mir vielleicht den Code noch etwas "erklären", ich verstehe leider noch nicht so viel da ich relativ neu auf dem Gebiet bin.
Wo müsste ich denn jetzt meine Daten einfügen um ein Organigramm mit meinen Werten zu erzeugen?
LG
Excel :)

[Fennek]

Hallo,

der Code ist nicht mehr als ein "Proof-of-Concept" und zeigt wie bestimmte Objekte angesprochen werden können.

Die einzige Anwendung wäre in einem bestehenden Diagramm gezielt Namen auszuwechseln, also bei Personalwechsel. In einer Liste müßten die alten und neuen Stelleninhaber verfügbar sein. Dann könnte ein leicht angepasster Code die neuen Namen ins Diagramm eintragen.

Wenn Du eine eher kleine Beispieldatei hochlädts, werde ich es mir ansehen.

mfg

[ExcelFoley69]

Ich habe hier einen Code eines ähnlichen Diagramms der funktioniert ungefähr,
aber ich würde ihn gerne auf mein Diagramm anwenden und auch verstehen. Sprich wo ich meine Daten hier einfügen kann in den Code.
Vielleicht hilft er dir auch ein wenig um einen Lösungsweg zu finden.
Liebe Grüße
Excel

Code:

Private Sub CreateDiagram(Source As Worksheet)
    'Preparation of SmartNode
    Dim oSALayout As SmartArtLayout, oshp, i%, QNode As SmartArtNode, _
    QNodes As SmartArtNodes, QTLNode As SmartArtNode
    Set oSALayout = Application.SmartArtLayouts(90)
    Set oshp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(oSALayout)
    Set QNodes = oshp.SmartArt.AllNodes
    For i = 1 To 5                                              ' delete all included nodes to form new ones
        oshp.SmartArt.AllNodes(1).Delete
    Next
   
     'Preparation of Information
     
    Dim rngMyRange As Range
    Dim rngCell As Range
    Set rngSource = Source.Range("B1:B2000")
    Dim employeeList As Collection
    Set employeeList = New Collection
    Dim employeeUnit As clsEmployee
    For Each rngCell In rngSource
        If rngCell.Value <> "" Then ' Bug: Falls in der Spalte Rolle (B) keine Werte stehen, wird ein fehlerhaftes Organigramm erstellt. Alle anderen Spalten können aber problemlos leere Zellen enthalten.
            Set employeeUnit = New clsEmployee
            employeeUnit.Role = rngCell.Value
            employeeUnit.Component = rngCell.Offset(, 1).Value
            employeeUnit.Additive = rngCell.Offset(, 2).Value
            employeeUnit.Firstame = rngCell.Offset(, 3).Value
            employeeUnit.Lastame = rngCell.Offset(, 4).Value
            Debug.Print employeeUnit.Firstame
            employeeList.Add employeeUnit
        End If
    Next rngCell
   
   
    'Size Smart Art
    oshp.Width = 35 * employeeList.Count
    oshp.Height = 35 * employeeList.Count
   
    'Build Teamleads
    Set QNode = oshp.SmartArt.AllNodes.Add
    Set QTLNode = QNode
    QNode.TextFrame2.TextRange.Text = "Projektleitung"
    For i = employeeList.Count To 1 Step -1
        'MsgBox "Name: " + empl.Firstame + " Wert: " + empl.Role
       
            If employeeList(i).Role = "PL" Then
                QNode.TextFrame2.TextRange.Text = employeeList(i).Firstame + " " + employeeList(i).Lastame + ""
                QNode.Shapes(2).TextFrame2.TextRange.Text = employeeList(i).Role + " " + employeeList(i).Component + ""
                employeeList.Remove i
            End If
       
    Next i

    Dim componentList As Collection
    Set componentList = New Collection
    Dim j As Integer
    Dim exist As Boolean
    exist = False
    'Anzahl der Einträge in Spalte 1 der Variable size zuweisen
   
   
    size = componentList.Count
   
    'Die Größe des Arrays anpassen

    For Each empl In employeeList
       
        For j = 1 To size
            If empl.Component = componentList(j) Then
                exist = True
                Exit For
            Else
                exist = False
            End If
        Next j

        If Not exist Then
            componentList.Add empl.Component
            size = componentList.Count
            exist = False
        End If
    Next empl
   
 
    Dim k As Integer
   
   
    For Each cmpnt In componentList
        Set QNode = QTLNode
        For k = employeeList.Count To 1 Step -1
            If cmpnt = employeeList(k).Component Then
                Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
                QNode.TextFrame2.TextRange.Text = employeeList(k).Firstame + " " + employeeList(k).Lastame + " " + employeeList(k).Role + ""
                QNode.Shapes(2).TextFrame2.TextRange.Text = employeeList(k).Component + " " + employeeList(k).Additive + ""
           
                   
            End If
        Next k
    Next cmpnt
   
    ActiveSheet.Range("A1:F500").ClearContents

End Sub

[Fennek]

Hallo,

ich nehme es mal mit Humor:

Der Code stammt von einem Dienstleister, der mit Absicht etwas kompliziert programmiert hat, damit nicht jeder das modifizieren kann?

Es scheint ein Klassenmodul ("Dim employeeUnit As clsEmployee") eingebunden zu sein, damit ist der Code nicht mehr direkt nach zu vollziehen.

Nur meine Einarbeitung in den Code (nur mit Daten) würde wesentlich länger dauern, als ich bereit bin hier tätig zu werden.

Vielleicht möchte jemand anderes.

(oder ein Dienstleister)

mfg

[ExcelFoley69]

Ich kanns dir leider nicht sagen da ich es selber nicht verstehe,
mir würde es aber auch vollkommend ausreichen wenn ich das Organigramm quasi "nachbaue" und der Name und die Position einfach in eine Zelle untereinander geschrieben wird auf einem neuen Sheet und das dann eben so ähnlich aussieht. Quasi im Format einer Pyramide oder sowas. Vielleicht dass die Zellen dann noch bunt hinterlegt sind. Muss dann nicht mit dem Smart Art sein, vor allem wenn das eh so schwer zu programmieren ist dann wird das für mich als Anfänger denke ich unmöglich :D

Liebe Grüße

[shift-del]

Moin

Steht Visio zur Verfügung?

Alter Weg:
https://www.youtube.com/watch?v=O2qWMFtyT3s

Neuer Weg:
https://www.myonlinetraininghub.com/visi...ree-add-in

[maninweb]

Moin,

einen Artikel zum Visio Data Visualizer Add-In habe ich auch in Deutsch zur Verfügung. Damals noch in einer Preview,
hat sich m.W. im Großen und Ganzen zur jetzigen Version im Aufbau nicht verändert, aber Bugs haben sie behoben.

Falls jemand das Add-In verwendet und Rückmeldung über das Add-In geben möchte, gerne auch an mich.
Ich kann das weiterleiten.

Gruß

[schauan]

Hallöchen,

Es scheint ein Klassenmodul ("Dim employeeUnit As clsEmployee") eingebunden zu sein, damit ist der Code nicht mehr direkt nach zu vollziehen.

Der Code zum clsEmployee wäre dann auch sicher von Vorteil