Excel VB Organogram

[anuradhagrewal]

Hi Folks
I need to make an organogram using excel VB.
The excel file and the format is given here.
What I am looking for is an organogram that is made horizontally with the CEO on the top the VP below it and then so on
I tried this code but it is making it vertically an not connecting the reportee to their boss.
Please help me out
What I am also looking is that the box shapes auto adjust as I intend to print this on A3 paper. The arrangement is just not happening. I mean the tree is so confusing if u guys see.
As you can see I am not able to go beyond Reportee 3 Column F as I want that Reportee 4 defined in column 4 is not happening
What I want to do is with Reportee 4 (column G) is that if there are 4 executive sales reporting to Asst Mgr-I so they need to be further defined. But all these 4 executives will be on the same level as they will be reporting to a Asst Mgr-I
Also I am looking at a dynamic code which automatically adjusts the reporting structure when it is changed in the main sheet named Organogram

Sub CreateOrganogramTest()
    Dim ws As Worksheet, wsSource As Worksheet
    Dim topShape As Shape, newShape As Shape
    Dim leftPos As Single, topPos As Single
    Dim shapeWidth As Single, shapeHeight As Single
    Dim i As Integer, j As Integer
    Dim reportTo As Variant, reports() As Variant

    ' Source worksheet with data
    Set wsSource = ThisWorkbook.ActiveSheet
    
    ' Create a new worksheet for the organogram
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "Organogram"
    
    ' Initial position and size of the first rectangle
    leftPos = 50
    topPos = 50
    shapeWidth = 100
    shapeHeight = 40
    
    ' Array of reporting structure
    reportTo = Array("B3", Array("C3", "C51", "C99", "C101"), _
                     "C3", Array("D3", "D15", "D27", "D39"), _
                     "C51", Array("D51", "D63", "D75", "D87"), _
                     "C99", Array("D99", "D100"), _
                     "C101", Array("D101"), _
                     "D3", Array("E3", "E6", "E9", "E12"), _
                     "D15", Array("E15", "E18", "E21", "E24"), _
                     "D27", Array("E27", "E30", "E33", "E36"), _
                     "D39", Array("E39", "E42", "E45", "E48"), _
                     "D51", Array("E51", "E54", "E57", "E60"), _
                     "D63", Array("E63", "E66", "E69", "E72"), _
                     "D75", Array("E75", "E78", "E81", "E84"), _
                     "D87", Array("E87", "E90", "E93", "E96"), _
                     "D99", Array("E99"), _
                     "D100", Array("E100"), _
                     "D101", Array("E101", "E102"))
    
    ' Loop through the reporting structure to create rectangles and connectors
    For i = LBound(reportTo) To UBound(reportTo) Step 2
        ' Create or find the top shape
        If i = 0 Then
            Set topShape = ws.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, shapeWidth, shapeHeight)
            topShape.TextFrame.Characters.Text = wsSource.Range(reportTo(i)).Value
            topPos = topPos + shapeHeight + 10 ' Adjust for next row
        Else
            Set topShape = ws.Shapes(wsSource.Range(reportTo(i)).Value)
        End If
        
        ' Loop through reports
        For j = LBound(reportTo(i + 1)) To UBound(reportTo(i + 1))
            Set newShape = ws.Shapes.AddShape(msoShapeRectangle, leftPos + (j * (shapeWidth + 10)), topPos, shapeWidth, shapeHeight)
            newShape.TextFrame.Characters.Text = wsSource.Range(reportTo(i + 1)(j)).Value
            newShape.Name = wsSource.Range(reportTo(i + 1)(j)).Value ' Name the shape for future reference
            
            ' Draw a connector
            Dim conn As Shape
            Set conn = ws.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 100)
            conn.ConnectorFormat.BeginConnect topShape, 1
            conn.ConnectorFormat.EndConnect newShape, 1
        Next j
        topPos = topPos + shapeHeight + 50 ' Adjust for next row
    Next i
End Sub

Thanks Guys

 

[anuradhagrewal]

I have made some changes in the code but its not giving what's desired

Sub CreateOrganogramTestMod()
    Dim ws As Worksheet, wsSource As Worksheet
    Dim topShape As Shape, newShape As Shape
    Dim leftPos As Single, topPos As Single
    Dim i As Integer, j As Integer
    Dim reportTo As Variant, reports() As Variant
    Dim levelDepth As Integer, rowHeight As Integer, verticalSpacing As Integer

    ' Source worksheet with data
    Set wsSource = ThisWorkbook.ActiveSheet

    ' Create a new worksheet for the organogram
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "Organogram"

    ' Set landscape orientation and A3 print area
    ws.PageSetup.Orientation = xlLandscape
    ws.PageSetup.PaperSize = xlPaperA3

    ' Initial position of the first rectangle
    leftPos = 50
    topPos = 50

    ' Array of reporting structure
    reportTo = Array("B3", Array("C3", "C51", "C99", "C101"), _
                     "C3", Array("D3", "D15", "D27", "D39"), _
                     "C51", Array("D51", "D63", "D75", "D87"), _
                     "C99", Array("D99", "D100"), _
                     "C101", Array("D101"), _
                     "D3", Array("E3", "E6", "E9", "E12"), _
                     "D15", Array("E15", "E18", "E21", "E24"), _
                     "D27", Array("E27", "E30", "E33", "E36"), _
                     "D39", Array("E39", "E42", "E45", "E48"), _
                     "D51", Array("E51", "E54", "E57", "E60"), _
                     "D63", Array("E63", "E66", "E69", "E72"), _
                     "D75", Array("E75", "E78", "E81", "E84"), _
                     "D87", Array("E87", "E90", "E93", "E96"), _
                     "D99", Array("E99"), _
                     "D100", Array("E100"), _
                     "D101", Array("E101", "E102"))

    ' Calculate the maximum level depth for spacing
    levelDepth = 4 ' Adjust this based on your actual organogram depth
    rowHeight = 100 ' Height of each row
    verticalSpacing = 20 ' Vertical spacing between shapes

    ' Loop through the reporting structure to create rectangles and connectors
    For i = LBound(reportTo) To UBound(reportTo) Step 2
        If i > 0 Then
            topPos = topPos + rowHeight + verticalSpacing ' Adjust vertical position for next level
        End If

        ' Create or find the top shape
        If i = 0 Then
            Set topShape = ws.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, 1, 1) ' 1x1 size initially
            topShape.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black background
            topShape.TextFrame.Characters.Text = wsSource.Range(reportTo(i)).Value
            topShape.TextFrame.Characters.Font.Color = RGB(255, 255, 255) ' White text color
            AdjustShapeSize topShape ' Dynamically adjust size based on text
        Else
            Set topShape = ws.Shapes(wsSource.Range(reportTo(i)).Value)
        End If

        ' Loop through reports
        For j = LBound(reportTo(i + 1)) To UBound(reportTo(i + 1))
            Set newShape = ws.Shapes.AddShape(msoShapeRectangle, leftPos + (j * 200), topPos, 1, 1) ' 1x1 size initially
            newShape.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black background
            newShape.TextFrame.Characters.Text = wsSource.Range(reportTo(i + 1)(j)).Value
            newShape.TextFrame.Characters.Font.Color = RGB(255, 255, 255) ' White text color
            AdjustShapeSize newShape ' Dynamically adjust size based on text
            newShape.Name = wsSource.Range(reportTo(i + 1)(j)).Value ' Name the shape for future reference

            ' Draw a connector
            Dim conn As Shape
            Set conn = ws.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
            conn.ConnectorFormat.BeginConnect topShape, 3
            conn.ConnectorFormat.EndConnect newShape, 1
        Next j
    Next i

    ' Set print area for A3 sheet
    ws.PageSetup.PrintArea = ws.UsedRange.Address
End Sub