Excel VBA - 节点路径问题中的 For/While 循环

Question

所以，

我有一组字符串 (Connector_String)，其中包含显示所有可能连接的字符串（代表类似网络的节点连接）。 Connector_String 具有以下格式（我认为这会对我有所帮助，但如果需要我可以更改它）：

• 以"-" 开头和结尾
• 连接的节点（始终为 2）表示为 String1*String2
• "*"之前的节点表示方向。所以，对于上面那个，方向是String1 --> String2
• 由"-"分隔的连接节点

例如， -RANDIAC*RANDACBD-RANDV*RANDIF-...-RANDA*RANDACAC- 这意味着RANDIAC 与RANDACBD 等连接。还要注意RANDIAC 可以与另一个节点连接。

我正在尝试列出给定起点和终点的节点之间的所有可能路径。为此，我有两个字符串，其中包括所有起始节点 (Start_String) 和结束节点 (End_String)。格式如下： -RAND26RD-RAND06RD-...-RAND12RD-

我开始编写for 循环代码来遍历Connector_String，但我很快意识到我必须多次编写相同的循环（我不知道如何定义多少次）。然后我写了一个Do While 循环代码（我第一次使用它）最终根本没有运行（我不明白为什么）。然后，我尝试用我在Sub 上使用的相同for 循环编写Function，然后在Sub 和“功能”中运行Function（希望它会做同样的工作作为Do While 循环）。

我的代码都没有工作，但我正在添加我的最后一次尝试，因为建议将它放在问题上（尽管我怀疑有经验的人是否会阅读它，因为它写得不好 - 加上没有工作）。

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

最后，我的节点的另一个棘手问题是节点是双向的（所以，我可能有 String1*String2 和 String2*String1），这会导致创建无限循环的问题（我没有尝试解决在我的代码上，因为我什至无法获得一些路径）。

查看下面的字符串：

开始字符串

-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-

连接器字符串

-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-

希望有人可以帮助我。

Answer 1

将连接复制到名为Connector.txt 的文本文件，并保存在与工作簿相同的文件夹中。连接写入Sheet1 并路由到Sheet2。使用从连接器文件构建的字典 dict 跟踪路由。 route 数组在沿路径递归时存储节点。端点以黄色突出显示。

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