Creating an organizational chart in Excel

lzweifel

lzweifel

Board Regular
Joined
Feb 21, 2006
Messages
213
Hi everyone.... I am trying to create an organizational chart. What I would like to do is put in one sheet the Role | Rank, etc and have it organize into a chart in another sheet. Any direction on where to get information on this?
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
.
Using this code (from this resource - Create an Org Chart/Vertical Hierarchy tree with VBA | Windows Secrets Lounge ) :

Code: 
Public TreeCol As Integer  'START OF NEXT TREE
Public LevelTop As Integer 'START OF NEXT LEVEL
Public LevelLeft As Integer  'LEFT STARTING POINT
Public CountSub As Integer 'COUNTS NUMBER OF ASSTMANAGERS
Public Errchk As Integer '1= ERROR STATE


Public Sub BuildTree()
On Error Resume Next
Application.ScreenUpdating = False
'------------------------------------
'DECALRE AND SET VARIABLES
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim I As Integer, J As Integer  'LOOP VARIABLES
    Dim Level1 As Boolean, Level2 As Boolean 'TYPE VALIDATION
    Dim LevelType As String  'HIERARCHY TYPE (CEO,SENIORMANAGER,MANAGER)
    Dim OldLevelType As String  'HIERARCHY TYPE (ONE LEVEL UP)
    Set ws1 = Worksheets("data")
    Set ws2 = Worksheets("Tree")
    LevelTop = 15
    TreeCol = 100
    CountSub = 0
    Errchk = 0
    LastRow = 50 '= ActiveCell.CurrentRegion.Rows.Count
'------------------------------------
'DELETE TREE
    If Worksheets("Tree").Shapes.Count > 0 Then
        MsgBox "There is an existing tree present.  You must first delete the tree prior to creating a new one."
        Exit Sub
    End If
'------------------------------------
'BUILD TREE
    With Worksheets("Tree")
    For I = 2 To LastRow
    '------------------------------------
    'DETERMINE HIERARCHY TYPE BY THE COLUMN
        For J = 1 To 7 Step 2
            Level1 = WorksheetFunction.CountA(ws1.Cells(I, J))
            Level2 = WorksheetFunction.CountA(ws1.Cells(I, J + 1))
            If Level1 And Level2 Then
            '------------------------------------
            'SET PARAMETERS ACCORDING TO HIERARCHY ASND BUILD LINES
                Select Case J
                    Case 1  'CEO
                        ws1.Cells(I, 9) = "N"
                        LevelType = "CEO"
                        LevelLeft = TreeCol + 300
                        BuildLines OldLevelType, LevelType, LevelTop
                    Case 3  'Senior Manager
                        ws1.Cells(I, 9) = "Y"
                        LevelType = "SeniorManager"
                        LevelLeft = TreeCol
                        BuildLines OldLevelType, LevelType, LevelTop
                    Case 5  'Manager
                        ws1.Cells(I, 9) = "N"
                        LevelType = "Manager"
                        LevelLeft = TreeCol + 75
                        BuildLines OldLevelType, LevelType, LevelTop
                    Case 7  'AsstManager
                        ws1.Cells(I, 9) = "Y"
                        LevelType = "AsstManager"
                        LevelLeft = TreeCol + 150
                        BuildLines OldLevelType, LevelType, LevelTop
                 End Select
            '------------------------------------
            'IF ERROR RETURNED (1), HIERARCHY IN IMPROPER FORMAT
                If Errchk = 1 Then
                    MsgBox "Please check line " & I + 1
                    Worksheets("Input").Activate
                    Worksheets("Input").Rows(I + 1).Select
                    Exit Sub
                End If
            '------------------------------------
            'BUILD AND POPULATE TEXTBOXES
                .OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
                    DisplayAsIcon:=False, Left:=LevelLeft, Top:=LevelTop, Width:=100, Height:=77).Select
                .OLEObjects("TextBox" & I - 1).Object.MultiLine = True
                .OLEObjects("TextBox" & I - 1).Object.TextAlign = 2
                .OLEObjects("TextBox" & I - 1).Object.Value = Cells(I, J) & Chr(13) & _
                "=========" & Chr(13) & Cells(I, J + 1)
            '------------------------------------
            'VALIDATE Y/N AND SET COLOR
                If UCase(Cells(I, 9)) = "Y" Then
                    .OLEObjects("TextBox" & I - 1).Object.BackColor = vbGreen
                Else:
                    .OLEObjects("TextBox" & I - 1).Object.BackColor = vbYellow
                End If
                LevelTop = LevelTop + 105
                GoTo continue
            End If
        Next J
continue:
    OldLevelType = LevelType
    Next I
    End With
Worksheets("Input").Activate
Application.ScreenUpdating = True
End Sub


Private Sub BuildLines(oldtype As String, newtype As String, ByVal start As Integer)
'--------------------------------------------------
'DETERMINE RELATIONSHIP BETWEEN CURRENT AND PREVIOUS HIERARCHY
Worksheets("Tree").Activate
    If oldtype = "CEO" And newtype = "CEO" Then
        Errchk = 1
        MsgBox "Only one CEO is permitted"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "CEO" And newtype = "SeniorManager" Then CEOToSeniorManager start
    If oldtype = "CEO" And newtype = "Manager" Then
        Errchk = 1
        MsgBox "There must be a SeniorManager between a CEO and a Manager"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "CEO" And newtype = "AsstManager" Then
        Errchk = 1
        MsgBox "There must be a SeniorManager and a Manager between a CEO and a AsstManager"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "SeniorManager" And newtype = "CEO" Then
        Errchk = 1
        MsgBox "The CEO must precede the SeniorManager and only one CEO is permitted"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "SeniorManager" And newtype = "SeniorManager" Then
        Errchk = 1
        MsgBox "A SeniorManager must have at least one Manager"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "SeniorManager" And newtype = "Manager" Then SeniorManagerToManager start
    If oldtype = "SeniorManager" And newtype = "AsstManager" Then
        Errchk = 1
        MsgBox "There must be a Manager between a SeniorManager and AsstManager"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "Manager" And newtype = "CEO" Then
        Errchk = 1
        MsgBox "Only one CEO is permitted"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "Manager" And newtype = "SeniorManager" Then
        TreeCol = TreeCol + 300
        LevelTop = 120
        LevelLeft = TreeCol
        ManagerToSeniorManager LevelTop
    End If
    If oldtype = "Manager" And newtype = "Manager" Then ManagerToManager start
    If oldtype = "Manager" And newtype = "AsstManager" Then ManagerToAsstManager start
    If oldtype = "AsstManager" And newtype = "CEO" Then
        Errchk = 1
        MsgBox "Only one CEO is permitted"
        DeleteShapes
        GoTo continue
    End If
    If oldtype = "AsstManager" And newtype = "SeniorManager" Then
        TreeCol = TreeCol + 300
        LevelTop = 120
        LevelLeft = TreeCol
        AsstManagerToSeniorManager LevelTop
    End If
    If oldtype = "AsstManager" And newtype = "Manager" Then AsstManagerToManager start
    If oldtype = "AsstManager" And newtype = "AsstManager" Then AsstManagerToAsstManager start
continue:
    Worksheets("data").Activate
End Sub


'****************************
'* LEVEL TO LEVELS ROUTINES *
'****************************


Public Sub CEOToSeniorManager(start As Integer) '120
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 345, start - 15).Select 'HOR
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 345, start - 15, TreeCol + 345, start - 30).Select 'V DN
    FormatLine
    CountSub = 0
End Sub


Public Sub SeniorManagerToManager(start As Integer) '(225)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 30, TreeCol + 45, start + 37).Select 'Verticle
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start + 37, TreeCol + 75, start + 37).Select 'Horizontal
    FormatLine
    CountSub = 0
End Sub


Public Sub ManagerToSeniorManager(start As Integer)
Select Case TreeCol
    Case 100 'Tree 1
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 345, start - 15).Select 'HOR
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 345, start - 15, TreeCol + 345, start - 30).Select 'V DN
        FormatLine
    Case 400 'Tree 2
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
    Case Is >= 700 'Trees >=3
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol - 255, start - 15).Select 'HOR
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
End Select
CountSub = 0
End Sub


Public Sub ManagerToManager(start As Integer)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 68, TreeCol + 45, start + 37).Select 'Verticle
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start + 37, TreeCol + 75, start + 37).Select 'Horizontal
    FormatLine
    CountSub = 0
End Sub


Public Sub ManagerToAsstManager(start As Integer) '(225)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 120, start - 30, TreeCol + 120, start + 37).Select 'Verticle
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 120, start + 37, TreeCol + 150, start + 37).Select 'Horizontal
    FormatLine
    CountSub = CountSub + 1
End Sub


Public Sub AsstManagerToSeniorManager(start As Integer)
Select Case TreeCol
    Case 100 'Tree 1
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 345, start - 15).Select 'HOR
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 345, start - 15, TreeCol + 345, start - 30).Select 'V DN
        FormatLine
    Case 400 'Tree 2
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
    Case Is >= 700 'Trees >=3
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol - 255, start - 15).Select 'HOR
        FormatLine
        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 15, TreeCol + 45, start).Select 'V UP
        FormatLine
End Select
CountSub = 0
End Sub


Public Sub AsstManagerToManager(start As Integer) '(225)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start - 68 - (105 * CountSub), TreeCol + 45, start + 37).Select 'Verticle
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 45, start + 37, TreeCol + 75, start + 37).Select 'Horizontal
    FormatLine
    CountSub = 0
End Sub


Public Sub AsstManagerToAsstManager(start As Integer)
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 120, start - 68, TreeCol + 120, start + 37).Select 'Verticle
    FormatLine
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, TreeCol + 120, start + 37, TreeCol + 150, start + 37).Select 'Horizontal
    FormatLine
    CountSub = CountSub + 1
End Sub


'********************************
'* END LEVEL TO LEVEL ROUTINES *
'********************************


Public Sub FormatLine()
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .Weight = 2
    End With
End Sub


Sub DeleteShapes()
'--------------------------------
'CLEAR TREE SHEET
Dim Shp As Shape
For Each Shp In Worksheets("Tree").Shapes
Shp.Delete
Next Shp
End Sub




Public Sub Hierarchy()
Range("Harchy").ClearContents
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Input")
Set ws2 = Worksheets("data")
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
For I = 3 To LastRow
    Select Case ws1.Cells(I, 1)
        Case "CEO"
            col = 1
        Case "SeniorManager"
            col = 3
        Case "Manager"
            col = 5
        Case "AsstManager"
            col = 7
    End Select
    ws2.Cells(I - 1, col) = ws1.Cells(I, 1)
    ws2.Cells(I - 1, col + 1) = ws1.Cells(I, 2)
Next I
BuildTree
End Sub


Download project here ---> https://www.amazon.com/clouddrive/s...cSpfNgDSSPYYLomQ1Y?ref_=cd_ph_share_link_copy
 
Upvote 0
Hi Logit,

Thank you very much for your prompt reply :).

I've succeeded to download the file.

Thanks again :)

Kind Regards
 
Upvote 0
.
You are welcome. Glad to help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Google Sheets: How to show multiple dates for the same task on the same row in a GANTT/timeline
Replies
0
Views
520
Exidur
E
J
  • Question Question
Google Combo Charts
Replies
1
Views
240
jimbogarner
J
L
  • Question Question
Bar Graph not showing Correctly
Replies
0
Views
237
LllopezXC
L
J
  • Question Question
Remove contextual menus in Excel 365 on Android OS
Replies
4
Views
250
jpbegley
J
C
  • Question Question
Pull specific row data into new tab
Replies
5
Views
397
Rhodie72
Rhodie72

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top