接受回答作者理解的问题
我的代码在下面的工作表上运行。代码创建了所需的输出，但我只能通过七个嵌套循环来防止代码进入无限循环;每行数据一个。目前的数据只是一个例子，预计最多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列模板的Cells组合
原始问题：
我所做的代码完美无缺！但这只是因为我在“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
SO， 问题是：当你有X行时如何做到这一点，以避免无限的“下一个”循环???? 有人有答案或告诉我应该遵循哪种方法？
答案 0 :(得分：0)
我尽可能完整地测试了我的代码。我增加了数据表的高度和宽度，并包含了错误的值。但是，用实际值进行测试是无可替代的。如果任何输入值无法给出您期望的结果，请告诉我。
我还没有研究过您的代码。我可能会找到一个简单的修正来阻止无限循环。但是，发现这种简单的修正需要很长时间，代码仍然依赖于当前的表大小。下面的代码都是新的。
我将参考：
我的代码首先发现数据表的真实大小。也就是说，我的代码不假设数据表是五列宽或17行深。
我的宏要求数据表标题包含数据表每列的文本值。您使用过“Col1”，“Col2”，“Col3”等。我的代码不依赖于这些名称，但它会回复每列都有一个值。
如果将光标定位到单元格C6并单击 Ctrl + 右，光标将跳转到单元格G6。如果您不熟悉 Ctrl + 箭头，请进行播放并查看光标的移动方式。我的代码使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”。我不知道你是否可以在第一行中拥有多个值，但很容易考虑到这种可能性。在您的示例中，我将在Pending中有一个包含序列（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调用ProcessC调用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））之前，Control将加载数据表并初始化结果表，其中（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 Output，您会看到它在结果表中提供与您目前相同的序列。
我不直接将结果输出到工作表。相反，我创建了一个数组，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