How to display direct and indirect counts for Subordinates in Visio Organization

[bradyguy]

I have seen a large number of post related to this but unfortunately I could not find an easy answer to being able to display counts in org charts for Visio. As a result I coded (hacked may be a better term) the following macro for the desired functionality. Hopefully others will find it useful.

RecursiveCount - this is a recursive method that count subs uses and it does all the work.

CountSubs - This is the starting point. Select the top most node in your org chart then run this macro.

SetCountsToBlank - This is a little helper macro that resets all the org shapes on your diagram to "".

MakeBoxesBigger - This is another little helper macro that runs through and re-sizes your shapes. I have used this when I get long names etc. with moderate success. There may be better ways to do this with in the orgchart stuff.

Function RecursiveCount(s As Shape) As String
    Dim count As Integer
    
    count = 0
    dc = s.FromConnects.count - 1
    
    For i = 1 To s.FromConnects.count
       If s.Text <> s.FromConnects(i).FromSheet.Connects(2).ToSheet.Text Then
            count = count + 1
            rc = RecursiveCount(s.FromConnects(i).FromSheet.Connects(2).ToSheet)
            count = count + rc
       End If
    Next
    If dc > 0 Then
        s.Shapes(4).Text = dc
        If (count > 0) And (count <> dc) Then
            s.Shapes(4).Text = s.Shapes(4).Text & "(" & count & ")"
        End If
    End If
    RecursiveCount = count
End Function
 
Sub CountSubs()
    ' select the top most node then run this macro
    Dim s As Shape
    Set s = ActiveWindow.Selection(1)
    
    ' now recursively update counts
    i = RecursiveCount(s)
    
End Sub
 
Sub SetCountsToBlank()
Dim s As Shape
For Each s In ActivePage.Shapes
        If s.Shapes.count >= 4 Then
            s.Shapes(3).Text = ""
            s.Shapes(4).Text = ""
    
        End If
    Next
End Sub
 
Sub MakeBoxesBigger()
Dim s As Shape
For Each s In ActivePage.Shapes
    If (s.Type = 2) Then
        s.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "1.37 in"
        s.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "0.6 in"
    End If
    Next
End Sub