用于创建组合的 VBA 宏

Question

我正在尝试为下面提到的情况编写一个宏。

输入是：

Col A   Col B
A       B
A       C
B       D
C       A
C       B
C       E
D       A
D       B
E       A

我正在尝试进行组合，例如 输出：

A   B   D   A       
A   C   A           
A   C   B   D   A   
A   C   E   A       
B   D   B           
C   A   B   D   A   C
C   A   C           
C   B   D   A   C   
C   E   A   C

|
|
|

等等

输出可以在同一个工作表上。

输出的起点和终点应该相同。 循环应从第一行开始，并以起点和终点相同的方式寻找组合。

我根本不知道如何创建这样的循环。

请提出一些想法。

Answer 1

有向图，避免循环和递归。美丽的挑战。 代码需要很多改进，但现在是凌晨 1 点，我不得不在家安装 Excel：/

我假设您的数据在 A1:B9 范围内。解决方案打印在即时窗口中（您自己的格式工作）。

Option Explicit

Sub EveningFun()

    Dim rCell As Range
    Dim rRng As Range

    Dim goal As String

    Dim availablePaths(1 To 9) As Boolean

    Dim i As Integer

    For i = 1 To 9
        availablePaths(i) = True
    Next i


    Set rRng = Sheet1.Range("A1:A9")

    For Each rCell In rRng.Cells
        goal = rCell.value

        Call RecursiveFun(goal, rCell.Offset(0, 1).value, goal, availablePaths)

    Next rCell

End Sub

Sub RecursiveFun(goal As String, nextElement As String, path As String, availablePaths() As Boolean)

    Dim rCell As Range
    Dim rRng As Range

    Set rRng = Sheet1.Range("A1:A9")

    For Each rCell In rRng.Cells

        If goal = nextElement Then
            'Debug.Print path & nextElement
             Range("D" & Rows.Count).End(xlUp).Cells.Offset(1, 0) = path & nextElement
             Exit Sub
        End If

        If nextElement = rCell.value And availablePaths(rCell.Row) Then
            Dim onePathLess(1 To 9) As Boolean
            Call CopyArrays(availablePaths(), onePathLess())
            'some key place, we have to avoid cycles
            onePathLess(rCell.Row) = False

            Call RecursiveFun(goal, rCell.Offset(0, 1).value, path & nextElement, onePathLess())
        End If

    Next rCell

End Sub

Sub CopyArrays(source() As Boolean, target() As Boolean)

    Dim i As Integer

    For i = 1 To 9
        target(i) = source(i)
    Next i

End Sub

+4 表示非常棒的任务，但 -3 表示没有尝试。