通过数字表生成每个可能的链
Posted
技术标签:
【中文标题】通过数字表生成每个可能的链【英文标题】：Generate every possible chain through a table of numbers 【发布时间】：2016-05-09 02:33:55 【问题描述】：接受答案的作者所理解的问题
我的代码在下面的工作表上运行。代码创建了所需的输出，但我只能通过七个嵌套循环来防止代码进入无限循环；每行数据一个。当前数据只是一个示例，预计最多 17 行的表格，因此这不是一种实用的方法。
数字表在 C7:G23 范围内。链从范围 C7:G7 开始。单元格 C7 中的 1 指向第 1 行，该行由 A 列中的 1 标识。范围 C8:G8 指定 1 后面可以跟 2、空白、空白、4 或空白。空白表示链的末端。 2 和 4 标识链中下一个可能的链接。当每个可能的链都被识别出来时，它被输出到 I1:P1 下的下一个空闲行。
任何人都可以建议如何在不存在无限循环的风险以及在数字表中每行没有一个嵌套循环的情况下实现此输出吗？
Row| A |B| C | D | E | F | G |H|I|J|K|L|M|N|O|P|
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
1| | | | | | | | | Test 3 |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
2| | | | | | | | |1|2| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
3| | | | | | | | |1|2|3|4|6| | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
4| | | | | | | | |1|2|3|4|6| | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
5| | | | | | | | |1|2|3|4|6|5| | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
6| | |Col1|Col2|Col3|Col4|Col5| |1|2|3|4|6|5| | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
7|Rows| | 1 | | | | | |1|2|3|4|6|5| | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
8| 1| | 2 | | | 4 | | |1|2|3|4|6|5| | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
9| 2| | | 3 | | | | |1|2|3|4|6|5| | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
10| 3| | 4 | | | | | |1|2|3|4|6| | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
11| 4| | 6 | | | | | |1|2|3|4|6| | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
12| 5| | | | | | | |1|2|3|4| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
13| 6| | | | 5 | | | |1|2|3|4| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
14| 7| | | | | | | |1|2|3|4| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
15| 8| | | | | | | |1|2|3|4| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
16| 9| | | | | | | |1|2|3| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
17| 10| | | | | | | |1|2|3| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
18| 11| | | | | | | |1|2|3| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
19| 12| | | | | | | |1|2|3| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
20| 13| | | | | | | |1|2| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
21| 14| | | | | | | |1|2| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
22| 15| | | | | | | |1|2| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
23| 16| | | | | | | |1| | | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
24| | | | | | | | |1| | | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
25| | | | | | | | |1|4|6| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
26| | | | | | | | |1|4|6| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
27| | | | | | | | |1|4|6|5| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
28| | | | | | | | |1|4|6|5| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
29| | | | | | | | |1|4|6|5| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
30| | | | | | | | |1|4|6|5| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
31| | | | | | | | |1|4|6|5| | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
32| | | | | | | | |1|4|6| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
33| | | | | | | | |1|4|6| | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
34| | | | | | | | |1|4| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
35| | | | | | | | |1|4| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
36| | | | | | | | |1|4| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
37| | | | | | | | |1|4| | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
38| | | | | | | | |1| | | | | | | |
|----+-+----+----+----+----+----+-+-+-+-+-+-+-+-+-|
原标题：Excel vba - 如何在“for next”循环中避免 X 次“for next”循环以找到 X 行和 5 列模板的单元格组合
原始问题：
我完成的代码运行良好！但只是因为我在“for next”循环中重复了 7 次（由于 7 行）“for next”循环......（见下文）。
Sub test3()
Range("I2:P40").ClearContents
' "Tableau" means matrix in french
Dim Tableau() As Long
' "l" means row (it is like r)
ReDim Tableau(l)
l = 0
' "l0" means row 0 (it is like r0)
Dim l0 As Long
Dim Pass As Long
l0 = 7
Pass = 2
'"PlagePX" Range of row addresses. To take in account for combinations in the matrix
Dim PlagePX As Range
Set PlagePX = Range(Cells(l0, 1), Cells(23, 1))
Cells(l0, 1).Select
Cells(l0, 3).Select
' "CL" means columns of row1,2,3,4,5,... (it is like RC1,2,3,4,5,...)
For CL1 = 1 To 5
If IsEmpty(Cells(l0, 3)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(l0, 3).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL1).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l), 2 + CL1).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Exit For
End If
For CL2 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL1)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL1).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL2).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 1), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l), 2 + CL2).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 1), 2 + CL1).Value
Pass = Pass + 1
Exit For
End If
For CL3 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL2)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL2).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL3).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 2), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 1), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l), 2 + CL3).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 2), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 1), 2 + CL2).Value
Pass = Pass + 1
Exit For
End If
For CL4 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL3)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL3).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL4).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 3), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 2), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 1), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l), 2 + CL4).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 3), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 2), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 1), 2 + CL3).Value
Pass = Pass + 1
Exit For
End If
For CL5 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL4)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL4).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL5).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 4), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 3), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 2), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 1), 2 + CL4).Value
Cells(Pass, 14) = Cells(Tableau(l), 2 + CL5).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 4), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 3), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 2), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 1), 2 + CL4).Value
Pass = Pass + 1
Exit For
End If
For CL6 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL5)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL5).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL6).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 5), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 4), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 3), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 2), 2 + CL4).Value
Cells(Pass, 14) = Cells(Tableau(l - 1), 2 + CL5).Value
Cells(Pass, 15) = Cells(Tableau(l), 2 + CL6).Value
l = l + 1
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 5), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 4), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 3), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 2), 2 + CL4).Value
Cells(Pass, 14) = Cells(Tableau(l - 1), 2 + CL5).Value
Pass = Pass + 1
Exit For
End If
'The question is which approach I should follow for X rows,
'to avoid repeating again and again a "For Next" loop in a "For Next" loop???
For CL7 = 1 To 5
If IsEmpty(Cells(Tableau(l - 1), 2 + CL6)) = False Then
ReDim Preserve Tableau(l)
Tableau(l) = Application.WorksheetFunction.Match(Cells(Tableau(l - 1), 2 + CL6).Value, PlagePX, 0) + 6
Cells(Tableau(l), 1).Select
Cells(Tableau(l), 2 + CL7).Select
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 6), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 5), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 4), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 3), 2 + CL4).Value
Cells(Pass, 14) = Cells(Tableau(l - 2), 2 + CL5).Value
Cells(Pass, 15) = Cells(Tableau(l - 1), 2 + CL6).Value
Cells(Pass, 16) = Cells(Tableau(l), 2 + CL7).Value
Else
Cells(Pass, 9) = Cells(l0, 3).Value
Cells(Pass, 10) = Cells(Tableau(l - 6), 2 + CL1).Value
Cells(Pass, 11) = Cells(Tableau(l - 5), 2 + CL2).Value
Cells(Pass, 12) = Cells(Tableau(l - 4), 2 + CL3).Value
Cells(Pass, 13) = Cells(Tableau(l - 3), 2 + CL4).Value
Cells(Pass, 14) = Cells(Tableau(l - 2), 2 + CL5).Value
Cells(Pass, 15) = Cells(Tableau(l - 1), 2 + CL6).Value
Pass = Pass + 1
Exit For
End If
Pass = Pass + 1
Next
l = l - 1
Next
l = l - 1
Next
l = l - 1
Next
l = l - 1
Next
l = l - 1
Next
l = l - 1
Next
MsgBox "fin"
End Sub
所以， 问题是：当你有 X 行时如何做以避免无限的“for next”循环？？？？ 有人有答案或告诉我应该遵循哪种方法吗？
【问题讨论】：
【参考方案1】：我已经尽可能全面地测试了我的代码。我增加了数据表的高度和宽度，并包含了错误的值。但是，没有什么可以替代用真实值进行的测试。如果任何输入值未能提供您期望的结果，请告诉我。
我没有研究过你的代码。我可能会找到一个简单的更正来防止无限循环。但是，找到简单的更正需要很长时间，并且代码仍然依赖于当前的表大小。下面的代码是全新的。
我会参考：
C6:G6 作为数据表头。 C7:G23 作为数据表。 I2:P100 作为结果表。我的代码从发现数据表的真实大小开始。也就是说，我的代码不假设数据表是 5 列宽或 17 行深。
我的宏要求数据表标题包含数据表每一列的文本值。您使用过“Col1”、“Col2”、“Col3”等。我的代码不依赖这些名称，但它确实回复每一列都有一个值。
如果将光标定位到单元格 C6 并单击 Ctrl+Right，则光标会跳转到单元格 G6。如果你对 Ctrl+Arrow 不熟悉，不妨试一试，看看光标是如何移动的。我的代码执行 VBA 等效项来查找数据表标题的最后一列。
现在我知道了数据表的宽度，我可以定义一个包含所有行的宽度范围。然后我可以从底部向上搜索该范围以查找具有值的第一行。这给了我数据表的最后一行。
我现在可以将整个数据表作为数组加载到 Variant 变量中。
执行上述操作的所有代码都在子程序LoadDataTable 中。我有一个子程序TestLoadDataTable 来证明数据表已通过将表输出到即时窗口正确加载，因此：
Row Col01 Col02 Col03 Col04 Col05
0 1
1 2 4
2 3
3 4
4 6 5
我有“0”，你有“绿色开始单元格”，否则这与你的数据表匹配。
将工作表范围加载到变体时，数组的下限始终为 1。上面标题中的列号是数组的真实列号。左侧列中的行号是减去 1 的真实行号。我没有将 A 列加载到该数组中；因为我不需要这些值。如果您的行不是数字顺序（根据您的示例），我们将需要几个额外的步骤，但这不是问题。
我正在将数据加载到数组中，因为从数组中取出数据更快更方便。
如果您不确定上述任何一项，请进行实验。尝试不同数量的行和列，看看TestLoadDataTable 输出什么宏。写下TestLoadDataTable 和LoadDataTable 并研究每个语句的效果。在线搜索任何您不知道定义的语句。
随着主程序沿数据表向下工作，序列将增长。它将从 (1) 开始，然后发现 (1 2)，然后是 (1 2 3)，然后是 (1 2 3 4)，然后是 (1 2 3 4 6)。我会将不断增长的序列保存在一个数组中。
我可以使用ReDim Preserve 来扩展数组，但我会尽可能避免使用ReDim Preserve。 ReDim Preserve 是一个非常有用的声明，但它是一个非常昂贵的声明。解释器必须为新的更大的数组找到空间，从旧数组中复制数据，初始化新部分并释放旧数组以进行垃圾回收。随着数组变得越来越大，这需要越来越长的时间，并且宏可能会变得缓慢。
如果数据表有 N 行，则序列不能有 N+1 个值而不重复一行。如果我调整一个数组的大小以容纳一个包含 N+1 个条目的序列，我知道它不能在没有重复的情况下被填充。起初我认为这足以防止无限循环。但是，我可以设计数据表，在填充数组之前生成大量半生序列。相反，我将按顺序检查所有先前条目的新条目；重复表示错误。
我有两种方法来管理序列。我认为第一种方法不会令人满意，但我会解释一下。
对于第一种方法，我将有一个待处理的数组或集合。你知道数组。 “集合”是大多数编程语言所说的“列表”。从集合中读取的方式与从数组中读取的方式相同。您可以轻松地将新条目添加到集合中或从集合中删除现有条目。数组比集合访问更快。下面的描述是高级别的，所以选择或数组或集合无关紧要。
Pending 中的每个条目都是一个不完整的序列。
我将首先为数据表第一行中的每个值在待处理中放置一个条目。您在第一行的第 1 列中有“1”。我不知道第一行是否可以有多个值，但很容易允许这种可能性。在您的示例中，我将有一个包含待处理序列 (1) 的条目。然后我会循环执行以下步骤，直到 Pending 为空。
对于每个循环，我都会复制 Pending 的最后一个条目，然后从 Pending 中删除最后一个条目。如果我将该副本称为 Work，那么在您的示例中，Work 包含 (1) 并且 Pending 现在为空。
查看数据表中标记为 1 的行，宏可以看到此序列的可能扩展为：(1 2)、(1 空)、(1 空)、(1 4) 和 (1 空)。表格的序列（1 个空）是完整的，可以写入结果表。序列 (1 2) 和 (1 4) 被添加到待处理中。
对于循环的第二次重复，Pending 现在有两个条目。代码将最后一个条目 - (1 4) - 复制到 Work 并将其从 Pending 中删除。可能的扩展是（1 4 6）、（1 4 空）、（1 4 空）、（1 4 空）和（1 4 空）。序列（1 4 空）是完整的，可以写入结果表。序列 (1 4 6) 被添加到待处理中。
如果您在纸上运行此序列，您可以快速了解它是如何为结果表生成结果的。循环中的代码很少，而且肯定比您拥有的代码少得多。你可能需要玩一会儿这个想法，但一旦掌握，它就很容易理解。不利的一面是，结果表中的条目将以非常奇怪的顺序排列：(1)、(1)、(1)、(1)、(1 4)、(1 4)、(1 4)、 (1 4), (1 4 6), (1 4 6), (1 4 6), (1 4 6), (1 4 6 5), (1 4 6 5), (1 4 6 5), (1 4 6 5)、(1 2) 等等。也许你会对这个序列感到满意。注意：我不明白为什么您对结果表中的重复项感到满意，但保留它们以匹配您的结果表。
另一种方法涉及递归。递归是另一个在突然变得容易之前无法理解的想法。我把它比作开车。您在第一节课结束时就知道，在向外看挡风玻璃和检查后视镜时，您将永远无法控制车轮、三个踏板、变速杆。但一个月后，你不记得你发现了什么困难。
假设您有 ProcessA，它调用 ProcessB，它调用 ProcessC。大多数初学者似乎很高兴解释器已经为所有 ProcessA 的数据找到了内存。他们也很高兴当 ProcessA 调用 ProcessB 时，解释器会为 ProcessB 的数据找到更多内存，因此 ProcessA 的数据在再次需要之前是安全的。当 ProcessC 被调用时，ProcessA 的数据和 ProcessB 的数据都是安全的。如果 ProcessA 调用 ProcessA，是否接受解释器将在第二个副本运行时保持 ProcessA 数据的第一个副本安全的一大步？
要让 ProcessA 调用自身，您需要 ProcessA 是迭代的。将 (1) 扩展到 (1 4)、将 (1 4) 扩展到 (1 4 6) 和将 (1 4 6) 扩展到 (1 4 6 5) 都是同一个问题，因此您可以使用相同的代码，每个代码都带有每个扩展都有自己的数据。
您需要三个例程，我将它们称为 Control、ExtendOrOutput 和 Output。控件将在调用 ExtendOrOutput((1)) 之前加载数据表并初始化结果表，其中 (1) 是初始序列。
ExtendOrOutput 将查看当前序列中的最后一个条目，在这种情况下，将 (1) 转换为 (1 2)、(1 空)、(1 空)、(1 4) 和 (1 空)。这些可能的扩展中的每一个都需要处理：
Call ExtendOrOutput((1 2))
Call Output((1 empty))
Call Output((1 empty))
Call ExtendOrOutput((1 4))
Call Output((1 empty))
现在Call ExtendOrOutput ((1 2)) 也会这样做：
Call Output((1 2 empty))
Call ExtendOrOutput((1 2 3))
Call Output((1 2 empty))
Call Output((1 2 empty))
Call Output((1 2 empty))
调用子例程的性质意味着Call ExtendOrOutput((1 2)) 下的所有内容都在第一个`Call Output((1 empty)) 之前执行，因此这些调用的执行顺序是：
Call ExtendOrOutput((1 2))
Call Output((1 2 empty))
Call ExtendOrOutput((1 2 3))
Call ExtendOrOutput((1 2 3 4))
Call ExtendOrOutput((1 2 3 4 6))
Call Output((1 2 3 4 6 empty))
Call Output((1 2 3 4 6 empty))
Call ExtendOrOutput((1 2 3 4 6 5))
Call Output((1 2 3 4 6 5 empty))
Call Output((1 2 3 4 6 5 empty))
Call Output((1 2 3 4 6 5 empty))
Call Output((1 2 3 4 6 5 empty))
Call Output((1 2 3 4 6 5 empty))
Call Output((1 2 3 4 6 empty))
Call Output((1 2 3 4 6 empty))
Call Output((1 2 3 4 empty))
Call Output((1 2 3 4 empty))
Call Output((1 2 3 4 empty))
Call Output((1 2 3 4 empty))
Call Output((1 2 3 empty))
Call Output((1 2 3 empty))
Call Output((1 2 3 empty))
Call Output((1 2 3 empty))
Call Output((1 2 empty))
Call Output((1 2 empty))
Call Output((1 2 empty))
Call Output((1 empty))
Call Output((1 empty))
Call ExtendOrOutput((1 4))
Call Output((1 empty))
如果您向下扫描Call Outputs，您会看到结果表中的序列与您当前的序列相同。
我不直接将结果输出到工作表。相反，我创建了一个数组 ResultsTable，然后输出到该数组。我已将此数组指定为 1,000 行。如果我填满数组，我会放弃。我不明白你为什么需要这些序列，但我想 1,000 已经绰绰有余了。如有必要，您可以增加或减少 1,000。如果这不能接受，我还有其他想法。
Option Explicit
' Constants are a good way of defining values that might change in the future
Const ColWshtDataTableLeft As Long = 3
Const RowWshtDataTableHdr As Long = 6
Const WshtName As String = "Data" ' Change to your name for the worksheet
Sub Control()
' Call LoadDataTable to copy the Data Table to an array
' Call ExtendOrOutput to create the Result Table of all chain through the Data Table
Dim ColDataTableCrnt As Long
Dim ColResultsTableCrnt As Long
Dim ColWshtCrnt As Long
Dim ColWshtResultTableLeft As Long
Dim DataTable As Variant
Dim ResultsTable As Variant
Dim RowDataTableCrnt As Long
Dim RowResultsTableCrnt As Long
Dim RowResultsTableCrntMax As Long
Dim Sequence() As Variant
Call LoadDataTable(DataTable) ' Load Data Table
' First column of Results Table which leave a blank column between Data Table
' and Results Table.
ColWshtResultTableLeft = ColWshtDataTableLeft + UBound(DataTable, 2) + 1
With Worksheets(WshtName)
' Delete columns to be used by Results Table plus those to the right or Results Table
.Columns(ColNumToCode(ColWshtResultTableLeft) & ":" & _
ColNumToCode(Columns.Count)).Delete
' Merge cells of header for Results Table. Width of Results Table is discussed below.
.Range(.Cells(1, ColWshtResultTableLeft), _
.Cells(1, ColNumToCode(ColWshtResultTableLeft + UBound(DataTable, 1) + 1))).Merge
With .Cells(1, ColWshtResultTableLeft)
.Value = "Results Table"
.HorizontalAlignment = xlCenter
End With
End With
' Size ResultsTable. Allow for 1,000 rows which I assume is more than could possibly
' be required. Width is height of Data Table + 2. "height of Data Table" allows a
' sequence to reference every row of the Data Table. I use the first extra column as
' a test for an over run. I do not think this is possible becuase of test for repeat
' row but thismakes absolute sure. I use to second extra column for an "error word"
' such as "Repeat" or "Overrun".
ReDim ResultsTable(1 To 1000, 1 To UBound(DataTable, 1) + 2)
RowResultsTableCrntMax = 0 ' Last used row in ResultsTable
'' Write values to ResultsTable to confirm entire table written to worksheet
'For RowResultsTableCrnt = 1 To UBound(ResultsTable, 1)
' For ColResultsTableCrnt = 1 To UBound(ResultsTable, 2)
' ResultsTable(RowResultsTableCrnt, ColResultsTableCrnt) = "'" & RowResultsTableCrnt & ":" & ColResultsTableCrnt
' Next
'Next
' Initialise the Sequence array
ReDim Sequence(0 To UBound(ResultsTable, 2))
Sequence(0) = 1 ' Last entry used
' Call ExtendOrOutput for every non-empty column in top row of DataTable.
' I know there will be a value in the first column. I do not know if there
' could be a value in later columns but no harm looking.
For ColDataTableCrnt = 1 To UBound(DataTable, 2)
If Not IsEmpty(DataTable(1, ColDataTableCrnt)) Then
Sequence(1) = DataTable(1, ColDataTableCrnt)
Call ExtendOrOutput(DataTable, ResultsTable, RowResultsTableCrntMax, Sequence)
End If
Next
' Output ResultTable to row 2 of Results Table in worksheet
With Worksheets(WshtName)
.Range(.Cells(2, ColWshtResultTableLeft), _
.Cells(UBound(ResultsTable, 1) + 1, _
ColWshtResultTableLeft + UBound(ResultsTable, 2) - 1)).Value = ResultsTable
End With
End Sub
Sub ExtendOrOutput(ByRef DataTable As Variant, ByRef ResultsTable As Variant, _
ByRef RowResultsTableCrntMax As Long, ByRef Sequence() As Variant)
' * DataTable as loaded from the worksheet. Values within DataTable are row
' numbers within DataTable except the value recorded is one less than the
' actual row number. Note: because DataTable has been loaded from a
' worksheet, dimension 1 is for rows and dimension 2 is columns.
' * ResultsTable be will loaded with completed sequences by Output. Note: because
' ResultsTable is to be written to a worksheet, dimensions are as for DataTable.
' ResultsTable has two more columns than should be necessary. In the event of
' an error with a sequence, an error word will be written to the last column.
' "Repeat" means a row number has repeated. "Overrun" means a value has been
' written to the penultimate column which should not be possible.
' * RowResultsTableCrntMax is the last currentlt used row within ResultsTable.
' * Sequence contains a sequence of row numbers which this routine will attempt
' to extend. If it cannot be extended, it is output to ResultsTable.
' Its definition is (0 to N+2) where N is the number of rows in DataTable.
' Entry 0 is used to hold the number of the last used entry within Sequence.
' Entry N+1 and N+2 are used as explained above under Results Table.
Dim ColDataTableCrnt As Long
Dim InxSequenceCrnt As Long
Dim InxSequenceMax As Long
Dim RepeatFound As Boolean
Dim RowDataTableCrnt As Long
If RowResultsTableCrntMax > UBound(ResultsTable, 1) Then
' Results Table is full
Exit Sub
End If
InxSequenceMax = Sequence(0) ' Last used entry in Sequence
RowDataTableCrnt = Sequence(InxSequenceMax) + 1 ' Last value in Sequence + 1
For ColDataTableCrnt = 1 To UBound(DataTable, 2)
If IsEmpty(DataTable(RowDataTableCrnt, ColDataTableCrnt)) Then
' This sequence is complete
Call Output(ResultsTable, RowResultsTableCrntMax, Sequence)
Else
' This sequence can be extended
InxSequenceMax = InxSequenceMax + 1
Sequence(InxSequenceMax) = DataTable(RowDataTableCrnt, ColDataTableCrnt)
Sequence(UBound(Sequence)) = "" ' No error
If IsNumeric(Sequence(InxSequenceMax)) Then
' Value is numeric but is it in range
If Sequence(InxSequenceMax) > -1 And Sequence(InxSequenceMax) < UBound(DataTable, 1) Then
' Value is a valid row number
RepeatFound = False
For InxSequenceCrnt = 1 To InxSequenceMax - 1
If Sequence(InxSequenceCrnt) = Sequence(InxSequenceMax) Then
' Repeated value
RepeatFound = True
Sequence(UBound(Sequence)) = "Repeat"
Call Output(ResultsTable, RowResultsTableCrntMax, Sequence)
End If
Next
If Not RepeatFound Then
' No repeat but is this an overrun?
If InxSequenceMax + 1 = UBound(Sequence) Then
' Have overrun. I don't think this is possible
Debug.Assert False
Sequence(UBound(Sequence)) = "Overrun"
Call Output(ResultsTable, RowResultsTableCrntMax, Sequence)
Else
' Have good extension
Sequence(0) = Sequence(0) + 1
Call ExtendOrOutput(DataTable, ResultsTable, RowResultsTableCrntMax, Sequence)
Sequence(0) = Sequence(0) - 1
End If
End If
Else
' Value is out of range
Sequence(UBound(Sequence)) = "Out of range"
Call Output(ResultsTable, RowResultsTableCrntMax, Sequence)
End If
Else
' Value is non-numeric so cannot be a row number
Sequence(UBound(Sequence)) = "Non-numeric"
Call Output(ResultsTable, RowResultsTableCrntMax, Sequence)
End If
' Restore Sequence ready for next column of DataTable
Sequence(InxSequenceMax) = ""
Sequence(UBound(Sequence)) = ""
InxSequenceMax = InxSequenceMax - 1
End If
Next
End Sub
Sub Output(ByRef ResultsTable As Variant, ByRef RowResultsTableCrntMax As Variant, _
ByRef Sequence As Variant)
' Copy contents of Sequence to next available row in ResultsTable
Dim InxSequenceCrnt As Long
RowResultsTableCrntMax = RowResultsTableCrntMax + 1
If RowResultsTableCrntMax > UBound(ResultsTable, 1) Then
' Results Table is full
Exit Sub
End If
For InxSequenceCrnt = 1 To UBound(Sequence)
ResultsTable(RowResultsTableCrntMax, InxSequenceCrnt) = Sequence(InxSequenceCrnt)
Debug.Print " " & Sequence(InxSequenceCrnt);
Next
Debug.Print
End Sub
Sub TestLoadDataTable()
' Call LoadTableTable then output its contents to the Immediate Window
Dim ColDTCrnt As Long
Dim DataTable As Variant
Dim RowDTCrnt As Long
Call LoadDataTable(DataTable)
' Output header row for DataTable
Debug.Print "Row";
For ColDTCrnt = 1 To UBound(DataTable, 2)
Debug.Print " Col" & Right("0" & ColDTCrnt, 2);
Next
Debug.Print
' Output DataTable
For RowDTCrnt = 1 To UBound(DataTable, 1)
Debug.Print Right(" " & RowDTCrnt - 1, 3);
For ColDTCrnt = 1 To UBound(DataTable, 2)
Debug.Print " " & Right(" " & DataTable(RowDTCrnt, ColDTCrnt), 5);
Next
Debug.Print
Next
End Sub
Sub LoadDataTable(ByRef DataTable As Variant)
' Determine the size of the Data Table and load its contents to DataTable
Dim ColDataTableRight As Long
Dim RowDataTableBottom As Long
With Worksheets(WshtName)
' * You have a header for the Data Table: Col1|Col2|Col3| . . .
' * This statement relies on there being a header. It does not matter what the header
' values providing the header is complete. This is the equivalent to positioning the
' cursor to the left cell of the header row and clicking Right. Since the start cell
' contains a value, it moves to the cell before the next empty cell
ColDataTableRight = .Cells(RowWshtDataTableHdr, ColWshtDataTableLeft).End(xlToRight).Column
' This statement first defines a range which is the width of the Data Table but includes
' all rows of the worksheet. It then searches from row 1 backwards (that is it starts
' the bottom row and searches upwards) until it finds a row with a value. This is the
' last row of the Data Table
RowDataTableBottom = .Range(.Cells(1, ColWshtDataTableLeft), _
.Cells(Rows.Count, ColDataTableRight)) _
.Find("*", .Cells(1, ColWshtDataTableLeft), xlFormulas, , xlByRows, xlPrevious).Row
' Import data table to DataTable
DataTable = .Range(.Cells(RowWshtDataTableHdr + 1, ColWshtDataTableLeft), _
.Cells(RowDataTableBottom, ColDataTableRight)).Value
End With
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim ColCode As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = ColCode
End Function
【讨论】：
以上是关于通过数字表生成每个可能的链的主要内容，如果未能解决你的问题，请参考以下文章