Excel VBA, Tracing logic/PERT using Visio?

[Tim_n]

Hi! This is my first post though I think I've come to MrExcel forums thousands of times.

I have a very large data set I'm analysing. What I'm doing is taking a fixed activity in time in a plan and working backwards to find all the activities that lead up to it. I've included a sort of snapshot of what I mean below. Except instead of 11 rows, I have 95,000. Of those 95k rows I've managed to rationalise it down to 5k and of those 5k isolated 700 erroneous tasks!

So for each of those 700 activities I have to again trace back down from the starting activity to the erroneous activity so I can analyse how it's linked and which link is throwing the error. It's not something I can automate and has to be done by a skilled human. Doing this in Excel doesn't work very well because it's just a mess of several hundred interlinked activities, so it'd be good to get a visualisation showing the links and then it would be very quick to work out which is the odd one out.

Drawing 700 Visio diagrams is a bit of a PITA and I've not touched writing MS Visio objects in Excel - any chance of some help? Ideally I just want to create a box with the project id, activity id and date concatenated into it (so no objects/templates (? Not sure if this is correct terminology) required!) and link each task as below. We can assume that the active sheet contains all the rows and is just drawing from it (no input boxes to draw from or to etc). It's not a one off, once I've got some idea how this stuff works I hope to build on it a bit.



[TABLE="width: 500"]
<tbody>[TR]
[TD]Predecessor[/TD]
[TD]Project ID[/TD]
[TD]Activity ID[/TD]
[TD]Date[/TD]
[TD]Successor
[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]activity A project ID txt
[/TD]
[TD]Activity A activity ID txt
[/TD]
[TD]Activity A Date txt
[/TD]
[TD]B
[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]etc
project ID txt
[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]D[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]F[/TD]
[/TR]
[TR]
[TD]E[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]H[/TD]
[/TR]
[TR]
[TD]G[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]H[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]I[/TD]
[TD]project ID txt[/TD]
[TD]activity ID txt[/TD]
[TD]Date txt[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Help very much appreciated!

 

[pbornemeier]

Put this code in a standard module:

On the activepage, data should be structured as follows, starting in row 2
A = Predecessor ID
B = Pred Data 1
C = Pred Data 2
D = Pred Data 3
E = Successor ID
Note: If a predecessor has multiple successors then a row must be added for that link, but the column B:D data is not required (and will be ignored) for the second and subsequent occurrences of that predecessor.

Run CreateNodeAndSuccArrays then in Visio use Design | Layout | Re-Layout Page options to get a prettier diagram.

NOTE: See these links for interesting alternatives/options:
Automating Diagrams with Visio « Boxes and Arrows
Graphviz | Graphviz - Graph Visualization Software

Option Explicit

Dim appVisio As Object

Sub CreateNodeAndSuccArrays()
    
    'Activesheet Data Starts at Row 2
    'Column A contains Node Identifier
    'Column B:D contains Column A Node Data
    'Column E contains Node successor
    'Note: If column
    
    Dim oNodes As Object
    Dim oLinks As Object
    Dim oSucce As Object
    Dim lLastRow As Long
    Dim aryNodes() As Variant
    Dim aryLinks() As Variant
    Dim varK As Variant
    Dim varI As Variant
    Dim rngCell As Range
    Dim lIndex As Long
    
    Dim sWorksheet As String
    
    sWorksheet = "Error Report"
        
    Set oNodes = CreateObject("Scripting.Dictionary")
    Set oLinks = CreateObject("Scripting.Dictionary")
    Set oSucce = CreateObject("Scripting.Dictionary")
    oNodes.CompareMode = vbTextCompare
    oLinks.CompareMode = vbTextCompare
    oSucce.CompareMode = vbTextCompare
    
    lLastRow = Cells(Rows.Count, 1).End(xlUp).row
    For Each rngCell In Range("A2:A" & lLastRow)
        'Update Node Dict
        If Not oLinks.exists(rngCell.Value) Then
            oNodes.Add rngCell.Value, rngCell.Offset(0, 1).Value & vbLf & _
                                      rngCell.Offset(0, 2).Value & vbLf & _
                                      rngCell.Offset(0, 3).Value
        End If
        'Update Link index
        oLinks.Item(rngCell.Value) = "," & rngCell.Offset(0, 4).Value & _
            oLinks.Item(rngCell.Value)
        'Update Successor index
        If rngCell.Offset(0, 4).Value <> vbNullString Then
            oSucce.Item(rngCell.Offset(0, 4).Value) = "," & _
                rngCell.Value & oSucce.Item(rngCell.Offset(0, 4).Value)
        End If
    Next
    
    varK = oNodes.Keys
    varI = oNodes.Items
    For lIndex = 0 To oNodes.Count - 1
        ReDim Preserve aryNodes(1 To 2, 1 To lIndex + 1)
        aryNodes(1, lIndex + 1) = varK(lIndex)
        aryNodes(2, lIndex + 1) = varI(lIndex)
    Next
    
    varK = oLinks.Keys
    varI = oLinks.Items
    For lIndex = 0 To oLinks.Count - 1
        ReDim Preserve aryLinks(1 To 2, 1 To lIndex + 1)
        aryLinks(1, lIndex + 1) = varK(lIndex)
        aryLinks(2, lIndex + 1) = Mid(varI(lIndex), 2)
    Next
    
    'Verify that all successors have entry in
    varK = oNodes.Keys
    For lIndex = 0 To UBound(varK)
        If oSucce.exists(varK(lIndex)) Then oSucce.Remove varK(lIndex)
    Next
    
    If oSucce.Count <> 0 Then
        varK = oSucce.Keys
        varI = oSucce.Items
        
        'Create Error Report Worksheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(sWorksheet).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet
    
        With Worksheets(sWorksheet)
            .Range("A1").Resize(1, 1).Value = _
                Array("Successors not identified as a Node")
            .Range("A1:B1").MergeCells = True
            .Range("A2").Resize(1, 2).Value = _
                Array("Successor ID", "Associated Predecessor(s)")
            .Range("A3").Resize(oSucce.Count, 1).Value = _
                Application.Transpose(varK)
            .Range("B3").Resize(oSucce.Count, 1).Value = _
                Application.Transpose(varI)
            
            lLastRow = .Cells(.Rows.Count, 2).End(xlUp).row
            With .Range("C3:C" & lLastRow)
                .FormulaR1C1 = "=MID(RC[-1],2,LEN(RC[-1])-1)"
                .Value = .Value
                .Copy Destination:=ActiveSheet.Range("B3")
                .ClearContents
            End With
            .Columns.AutoFit
        End With
        MsgBox oSucce.Count & " successor" & IIf(oSucce.Count = 1, " is", "s are") & " not also in entered in column A as a Node.  " & _
            "The 'Error Report' worksheet lists these missing nodes and their associated predecessors." & vbLf & vbLf & _
            "Either add the missing nodes and their associated data or remove them from their indicated predecessor(s).", , "Missing Nodes"
        GoTo End_Sub

    End If
    
    DrawNetwork aryNodes, aryLinks
    
End_Sub:
    Set oNodes = Nothing
    Set oLinks = Nothing
    Set oSucce = Nothing
End Sub

Sub DrawNetwork(aryNodes() As Variant, aryLinks() As Variant)
    'Given an array of nodes (with data) and pred-succ links plot them in visio
    'AryNodes(1 to 2, 1 to n)   1 = Node ID
    '                           2 = 3 elements of node data separated by tabs
    'aryLinks(1 to 2, 1 to m)   1 = Node ID
    '                           2 = Node IDs of successors separated by commas
    
    Dim aryContents() As Variant    '0...N
    Dim lAryIndex As Long
    Dim lAryRangeIndex As Long
    Dim lShapeIndex As Long
    Dim lLinkIndex As Long
    Dim aryTo As Variant
    Dim lToIndex As Long
    Dim sngX As Single
    Dim sngY As Single
    Dim sngDeltaX As Single
    Dim sngDeltaY As Single
    Dim lLastDropIndex As Long
    Dim lCurrDropIndex As Long
    Dim bAllInSameVisio As Boolean
    Dim lFrom As Long
    Dim lTo As Long
    Dim shp As Object
    Dim oNames As Object

    Set oNames = CreateObject("Scripting.Dictionary")
    oNames.CompareMode = vbTextCompare
    
    bAllInSameVisio = True
    
    If bAllInSameVisio Then
        'Is Visio already running
        On Error Resume Next
        ' Check whether PowerPoint is running
        Set appVisio = GetObject(, "Visio.Application")
        If appVisio Is Nothing Then
            ' Visio is not running, create new instance
            Set appVisio = CreateObject("visio.Application")
            appVisio.Visible = True
        End If
    Else
        'Open new copy of Visio
        Set appVisio = CreateObject("visio.Application")
        appVisio.Visible = True
    End If
    
    'Add New Drawing
    appVisio.Documents.AddEx "basicd_u.vst", 0, 0
    'Open Stencils if other shapes are required
    'AppVisio.Documents.OpenEx "comps_u.vss", 2 + 4  'visOpenRO + visOpenDocked
    'AppVisio.Documents.OpenEx "periph_u.vss", 2 + 4 'visOpenRO + visOpenDocked
    'AppVisio.Documents.OpenEx "basic_u.vss", 2 + 4  'visOpenRO + visOpenDocked
    
    'Initial Position
    sngDeltaX = 2
    sngDeltaY = 1.25
    sngX = 1
    sngY = 10.25
    
    'Plot Nodes
    For lShapeIndex = LBound(aryNodes, 2) To UBound(aryNodes, 2)
        
        'Drop Current stencil
        appVisio.ActiveWindow.Page.Drop appVisio.Documents.Item("BASIC_U.VSS").Masters.ItemU("Rectangle"), sngX, sngY
        lCurrDropIndex = appVisio.ActiveWindow.Selection.PrimaryItem.ID
        appVisio.ActiveWindow.Page.Shapes.ItemFromID(lCurrDropIndex).Name = CStr(aryNodes(1, lShapeIndex))        'Name Shape
        SetShapeText lCurrDropIndex, CStr(aryNodes(2, lShapeIndex))     'Add Text
        appVisio.ActiveWindow.Page.Shapes.ItemFromID(lCurrDropIndex).CellsSRC(3, 0, 7).FormulaU = "16 pt" 'visSectionCharacter, 0, visCharacterSize
        
        'Update Name to ID index
        oNames.Add CStr(aryNodes(1, lShapeIndex)), lCurrDropIndex
        
        'Calculate Next Position
        sngY = sngY - sngDeltaY
        If sngY < 1 Then
            sngY = 10.25
            sngX = sngX + sngDeltaX
        End If
    
    Next
    
    'Add Connections
    For lLinkIndex = 1 To UBound(aryLinks, 2)
        lFrom = oNames.Item(aryLinks(1, lLinkIndex))
        aryTo = Split(aryLinks(2, lLinkIndex), ",")
        For lAryIndex = LBound(aryTo) To UBound(aryTo)
            lTo = oNames.Item(aryTo(lAryIndex))
            appVisio.ActivePage.Shapes.ItemFromID(lFrom).AutoConnect appVisio.ActivePage.Shapes.ItemFromID(lTo), 0
        Next
    Next
    
    
    Set appVisio = Nothing
    Set oNames = Nothing
End Sub


Sub SetShapeText(lShapeID As Long, sEntry As String)
    'Add Text to Shape
    Dim vsoCharacters1 As Object
    
    Set vsoCharacters1 = appVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Characters
    vsoCharacters1.Begin = 0
    vsoCharacters1.End = 0
    vsoCharacters1.Text = sEntry
    appVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7).FormulaU = "18 pt"     'visSectionCharacter, 0, visCharacterSize
    
    Set vsoCharacters1 = Nothing

End Sub

 

[Tim_n]

Thanks that's spot on - all I need to do now is work out how to get it to run horizontally and how the spacing works! thanks Phil!

 

[pbornemeier]

You can get a left to right layout by selecting Design | Layout | Re-Layout Page
and then one of:
Flowchart | Left to Right
Hierarchy | Left to Right
Compact Tree | Right Then Down

also,

Design | Layout | Re-Layout Page | More Layout Options...
allows you to set spacing and a few other options

In any case it is likely that you will have to move a few things around by hand to get exactly what you want.

 

[Tim_n]

That sounds easier!

 

[Tim_n]

Yes, looks much better - infact, perfect!