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