Excel VBA - For/While Loop in a Node-Path Problem

So,

I have a set of string (Connector_String) which contains strings (which represent network-like nodes connections) that show all possible connections. The Connector_String has the following format (which I thought would help me but I can change it if needed):

• Starts and ends with "-"
• The nodes connected (always 2) represented as String1*String2
• The node before "*" indicate the direction. So, for that above, direction is String1 --> String2
• Connected nodes separated by "-"

For instance, -RANDIAC*RANDACBD-RANDV*RANDIF-...-RANDA*RANDACAC- Which means RANDIAC connects with RANDACBD etc. Also note that RANDIAC could be connected with another node.

I'm trying to list all possible path between the nodes given a starting and ending point. For that, I have two strings which include all the starting (Start_String) and ending nodes (End_String). The format is as follow: -RAND26RD-RAND06RD-...-RAND12RD-

I started writing a for loop code to iterate through the Connector_String but I soon realized that I have to write the same loop many times (which I do not know how to define how many). I then wrote a Do While loop code (first time ever for me to use it) which ended up not running at all (I don't understand why). Then, I tried to write a Function with the same for loop I use on the Sub and then run the Function in the Sub and in the 'Function' (hoping that will do the same job as the Do While loop).

None of my code have worked, but I'm adding my last attempt as it is recommended to have it on the question (although I doubt if an experienced person will read it as it is not well written - plus doesn't work).

Public Function Str_Search(a As String) As String
    
    Dim i As Long
    Debug.Print "Func " & a
    If InStr(End_Str, Split(a, "-")(UBound(Split(a, "-")))) > 0 Then
        Str_Search = a
        Exit Function
    End If
    
    For i = 1 To UBound(Split(Connector_String, "-")) - 1
        If Split(a, "-")(UBound(Split(a, "-"))) = Split(Split(Connector_String, "-")(i), "*")(0) Then
            a = a & "-" & Split(Split(Connector_String, "-")(i), "*")(1)
            Str_Search (a)
        End If
    Next i
    
End Function

Sub test_V4()
    Dim a As String
    Dim i As Long
    
    a = ""
    
    For i = 1 To UBound(Split(Connector_String, "-")) - 1
        If InStr(Start_String, Split(Split(Connector_String, "-")(i), "*")(0)) > 0 Then
            a = Replace(Split(Connector_String, "-")(i), "*", "-")
        ElseIf a <> "" Then
            Str_Search (a)
        ElseIf InStr(End_String, Split(a, "-")(UBound(Split(a, "-")))) > 0 Then
            Exit Sub
        End If
    Next

End Sub

Lastly, another tricky problem with my nodes is that there are nodes are bidirectional (so, I might have String1*String2 and String2*String1), which impose the problem to create infinite loop (I haven't not try to address that on my code as I can't even get a few paths).

See below the strings:

Start_String

-RAND_VW_E-RAND_VG_E-RAND_VG_F-RAND_M_2C-RAND_M_3A-RAND_VW_D-RAND_VW_V-RAND_M_1E-RAND_M_4E-RAND_VG_V-RAND_M_2D-RAND_M_3B-RAND_VW_C-RAND_VG_D-RAND_M_1F-RAND_M_4F-RAND_I_LINE-RAND_M_1E & RAND_M_4E-RAND_M_1F & RAND_M_4F

End_String

-RAND26RD-RAND06RD-RAND08RD-RAND12RD-RAND06RD-RAND02RD-RAND07RD-RAND01RD-RAND05RD-RAND03RD-RAND09RD-RAND04RD-RAND10RD-RAND20RD-RAND21RD-RAND22RD-RAND23RD-

Connector_String

-RANDIAC*RANDACBD-RANDV*RANDIF-RANDV*RANDIBD-RANDBD*RAND26RD-RANDACBD*RANDBD-RAND67F*RAND06RD-RAND89AC*RAND08RD-RANDACAC*RAND89AC-RANDA*RANDACAC-RAND_VW_E*RANDE-RAND_VG_E*RANDE-RAND_VG_F*RANDF-RAND_M_2C*RANDC-RAND_M_3A*RANDA-RANDEBD*RANDBD-RANDE*RANDEBD-RANDI*RANDIBD-RANDIBD*RANDBD-RANDF*RANDFNTH-RANDACAC*RANDACBD-RAND_VW_D*RANDD-RANDFSTH*RAND12F-RAND12F*RAND12RD-RANDIAC*RAND67AC-RAND67AC*RAND06RD-RANDFSTH*RAND02F-RAND02F*RAND02RD-RAND_VW_V*RANDV-RANDE*RANDEF-RAND_M_1E*RANDE-RAND_M_4E*RANDE-RANDEF*RANDFSTH-RAND_VG_V*RANDV-RANDV*RANDIAC-RANDFSTH*RAND67F-RAND67F*RAND07RD-RANDFNTH*RAND01RD-RANDIF*RANDFSTH-RANDB*RANDBD-RAND_M_2D*RANDD-RAND_M_3B*RANDB-RANDI*RANDIF-RANDIF*RANDFNTH-RANDFNTH*RAND05RD-RANDC*RANDACAC-RAND_VW_C*RANDC-RANDACAC*RAND67AC-RAND67AC*RAND07RD-RAND_VG_D*RANDD-RANDD*RANDBD-RAND_M_1F*RANDF-RAND_M_4F*RANDF-RANDFSTH*RAND03F-RAND03F*RAND03RD-RANDI*RANDIAC-RAND_I_LINE*RANDI-RANDIAC*RAND89AC-RAND89AC*RAND09RD-RANDF*RANDFSTH-RANDFSTH*RAND0410-RAND0410*RAND04RD-RAND0410*RAND10RD-RANDBD*RAND26BD-RANDFSTH*RANDFWST-RANDFWST*RANDFX-RAND20X*RAND20RD-RAND21X*RAND21RD-RANDFX*RAND21X-RANDFX*RAND20X-RANDEF*RANDFNTH-RANDACAC*RANDJET-RAND22Y*RAND22RD-RAND23Y*RAND23RD-RANDACY*RAND23Y-RANDJET*RANDACY-RANDACY*RAND22Y-RAND23Y*RAND23BD-RAND22Y*RAND22BD-RAND22Y*RAND23BD-RAND26BD*RAND22BD-RAND26BD*RAND23BD-RAND23BD*RAND26BD-RAND22BD*RAND26BD-RAND23BD*RAND23RD-RAND22BD*RAND22RD-RAND26BD*RAND26RD-RANDJET*RANDACX-RANDACX*RAND20X-RANDACX*RAND21X-RANDACX*RANDFX-RANDFX*RANDFWST-RANDFWST*RANDFSTH-RANDFSTH*RANDFNTH-

Hopefully, someone can help me with that.

Solution 1:

Copy the connections to a text file named Connector.txt and save in the same folder as the workbook. Connections are written to Sheet1 and routes to Sheet2. Routes are traced using the dictionary dict built from the connector file. The route array stores nodes as it recurses along the path. End points are highlighted in yellow.

Option Explicit 
Dim dictEnd As Object 
Dim dict As Object

Sub Str_Search()

    Const CONFILE = "Connector.txt"
    
    ' dictionaries
    Set dictEnd = CreateObject("Scripting.Dictionary")
    Call EndNodes(dictEnd)
    'MsgBox Join(dictEnd.keys, vbLf)

    Set dict = CreateObject("Scripting.Dictionary")
    Call ConnectedNodes(dict, ThisWorkbook.Path & "\" & CONFILE)
    ' dump source to check
    Call DumpConnected(Sheet1, dict)
    
    ' trace routes to sheet2
    Const STEPS = 20
    Dim route(1 To STEPS) As String, arStart, k
    Dim n As Long, r As Long
    r = 2
    arStart = StartNodes()
    With Sheet2
        .Cells.Clear
        .Cells(1, 1) = "Start Node"
        For n = 0 To UBound(arStart)
            k = arStart(n)
            If dict.exists(k) Then
                route(1) = k
                Call TraceRoute(route, 1, r, Sheet2)
                r = r + 1
            ElseIf Len(k) > 0 Then
               MsgBox k & " not found", vbCritical
            End If
        Next
        .Columns.AutoFit
    End With
    MsgBox "Done", vbInformation
    
End Sub

Sub TraceRoute(ByRef route, ByRef i As Long, ByRef r As Long, ws As Worksheet)

    'Debug.Print r, i, route(i)
    Dim node As String, dest As String
    Dim n As Long, j As Long, msg As String
    
    ' current node
    node = route(i)
    ws.Cells(r, i) = node
    
    ' is end node
    If dictEnd.exists(node) Then
        ws.Cells(r, i).Interior.Color = RGB(255, 255, 0)
    End If
        
    ' check not infinite loop
    For j = 1 To i - 1
        If route(j) = node Then
            msg = "Inf Loop "
            ws.Cells(r, i + 1) = msg
            r = r + 1
            Exit Sub
        End If
    Next
    
    ' end of route ?
    If Not dict.exists(node) Then
        r = r + 1
        Exit Sub
    End If
    
    msg = ""
    For n = 1 To dict(node).Count
        dest = dict(node).Item(n)
        
        ' recurse
        If dict.exists(dest) Then
            
            i = i + 1
            route(i) = dest
            Call TraceRoute(route, i, r, ws)
            i = i - 1
        Else
            ws.Cells(r, i + 1) = dest
            If dictEnd.exists(dest) Then
                ws.Cells(r, i + 1).Interior.Color = RGB(255, 255, 0)
            End If
            r = r + 1
        End If
    Next
    
End Sub

Function StartNodes() As Variant
    StartNodes = Split("-RAND_VW_E-RAND_VG_E-RAND_VG_F-RAND_M_2C-RAND_M_3A-RAND_VW_D-RAND_VW_V" & _
    "-RAND_M_1E-RAND_M_4E-RAND_VG_V-RAND_M_2D-RAND_M_3B-RAND_VW_C-RAND_VG_D" & _
    "-RAND_M_1F-RAND_M_4F-RAND_I_LINE-RAND_M_1E-RAND_M_4E-RAND_M_1F-RAND_M_4F", "-")
End Function

Sub EndNodes(ByRef d)
    Dim k
    For Each k In Split("-RAND26RD-RAND06RD-RAND08RD-RAND12RD-RAND06RD-RAND02RD-RAND07RD-RAND01RD" & _
    "-RAND05RD-RAND03RD-RAND09RD-RAND04RD-RAND10RD-RAND20RD-RAND21RD-RAND22RD-RAND23RD-", "-")
        If Len(Trim(k)) > 0 Then d(Trim(k)) = 1
    Next
    MsgBox d.Count & " End Nodes"
End Sub

Sub ConnectedNodes(ByRef d, filename As String)

    ' read connection file
    Dim FSO As Object, ts As Object, sTxt As String
    Set FSO = CreateObject("Scripting.FilesystemObject")
    Set ts = FSO.OpenTextFile(filename)
    sTxt = ts.readAll
    ts.Close
    
    ' regular expression
    Dim regex As Object, m As Object, node As Object
    Dim n As Long, k
    
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "(?:-([^*]+)\*([^-]+))"
    End With
    
    ' parse file
    If regex.test(sTxt) Then
        Set m = regex.Execute(sTxt) '
        For n = 1 To m.Count
            Set node = m.Item(n - 1).submatches
            k = Trim(node(0))
            If Not dict.exists(k) And Len(k) > 0 Then
                dict.Add k, New Collection
            End If
            dict(k).Add Trim(node(1))
        Next
    End If
    MsgBox d.Count & " Connectd Nodes"
End Sub

Sub DumpConnected(ws As Worksheet, dict)

    Dim k, r As Long, n As Long
    r = 1
    With ws
        .Cells.Clear
        .Cells(r, 1) = "Start Node"
        For Each k In dict
            r = r + 1
            .Cells(r, 1) = k
            For n = 1 To dict(k).Count
                .Cells(r, n + 1) = dict(k).Item(n)
            Next
        Next
        .Columns.AutoFit
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("A1"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange ws.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

End Sub