macros提取数据块

我一整天都在处理这个问题，无法解决。

input数据由多个具有相同行数和列数的数据块组成。 每个数据块在块的第一行中都有它的名字。 此外，他们进一步隔开一行空白。

block1 name score value a 2 3 b 3 5 c 1 6 block2 name score value a 4 6 b 7 8 c 2 6 block3 name score value a 5 4 b 7 8 c 2 9 

所需的输出是提取每个块的名称和值列，然后将其并列在列中。 喜欢这个：

 value block1 block2 block3 a 3 6 4 b 5 8 8 c 6 6 9 

谢谢你的帮助！

更新感谢您的回答，托尼和其他人！ 我只是有另一个要求。 有些表中的某一行可能丢失了。 换句话说，正如你之前提到的，行号可能会有所不同。 用NA可以填写这些表格中的相应单元格吗？ 即新的input是这样的：

 block1 name score value a 2 3 c 1 6 block2 name score value a 4 6 b 7 8 c 2 6 block3 name score value a 5 4 b 7 8 

现在所需的输出是这样的：

 value block1 block2 block3 a 3 6 4 b NA 8 8 c 6 6 NA 

7月3日更新（如果把这个问题过长是不恰当的，我会提出这个问题，并提出一个新的问题）

  block1 name score value a 2 3 b 3 5 c 1 6 block2 name score value a 4 6 b 7 8 c 2 6 block3 name score value a 5 4 b 7 8 c 2 9 

我怎样才能把价值和相应的分数都放到一个单元格中？ 像这样：代码表示该值被放入一个dynamic数组中。 然后.range被分配给这个数组。 我的第一个想法是构build另一个数组来存储“分数”列的值。 然后遍历这两个数组中的每个元素，并将它们连接在一起。 但是，似乎VBA确实允许我遍历数组，因为它的维度没有定义。 我试过REDIM，但是没有奏效。

 value block1 block2 block3 a 3(2) 6(4) 4(5) b 5(3) 8(7) 8(7) c 6(1) 6(2) 9(2) 

Answer 1

首先回答 – 介绍问题并要求澄清

这不是一个解决scheme – 你没有提供足够的信息解决scheme – 但介绍了问题和可能的技术。 警告：我已经将此input到记事本中; 没有保证没有语法错误。

你说每个表是相同的大小，虽然我不假设3×3。 但如果他们是3×3，我可以说表1开始在第1行，表2开始在第7行，表N开始在6（N-1）+1？ 也就是说，你可以计算每张桌子的位置还是你需要search？

如果您需要search，以下内容可能会有所帮助：

 Dim ColSrcLast as Long Dim RowSrcCrnt As Long RowSrcCrnt = 1 ' Assumed start of Table 1 With Worksheets("xxxx") ColSrcLast = .Cells(RowCrnt,Columns.Count).End(xlToLeft).Column End With 

ColSrcLast = .Cells(RowCrnt,Columns.Count).End(xlToLeft).Column是将光标放在行RowCrnt + 1的最后一列，然后单击Control + Left的VBA等效项。 这可能是查找表1中最后使用的列的最简单的方法。

Ctrl + Arrow键将光标移动到指定的方向，并：

• 如果当前单元格为空，则停在第一个非空单元格处，
• 如果当前单元格是非空白的，下一单元格是空白的，则停止在空白单元格之前的最后一个非空白单元格，
• 如果当前单元格不是空白，但下一个单元格是空白的，则停在下一个非空白单元格，
• 如果没有单元符合上述标准，则停止在范围的末尾。

实验和上述将变得更加清晰。

如果表之间的空行数量可能会有所不同，我认为以下将是最简单的定位每个表的方法：

 Dim Found As Boolean Dim RowSrcCrnt As Long Dim RowSrcLast As Long Dim RowSrcTableTitle As Long Dim RowSrcTableLast As Long With Worksheets("xxxx") ' Find last used row of worksheet RowSrcLast = .Cells(Rows.Count,"A").End(xlUp).Row End With RowSrcCrnt = 1 Do While RowSrcCrnt <= RowSrcLast With Worksheets("xxxx") Found = False Do While RowSrcCrnt <= RowSrcLast If .Cells(RowSrcCrnt,"A").Value = "" then ' Have found start of next (first) table RowSrcTableTitle = RowSrcCrnt Found = True Exit Do End If RowSrcCrnt = RowSrcCrnt+1 Loop If Not Found Then ' No more tables Exit Do End If RowSrcTableLast = .Cells(RowSrcTableTitle,"A").End(xlDown).Row End With ' Process table RowSrcTableTitle to RowSrcTableLast RowSrcCrnt = RowSrcTableLast+1 Loop 

在上面的循环中，我们有：将表RowSrcTableTitle处理到RowSrcTableLast。

名称列始终是列“A”？ 价值列总是最后一列吗？ 如果不是，则必须在标题行中search列名称。

每张桌子是否在同一个序列？ 如果不是，你将不得不对其进行sorting。 每个表是否包含每一行？ 如果没有，你的代码组合表将不得不允许这一点。

我希望以上让你开始。 回来，如果你有具体的问题。

第二个答案 – 回应澄清

我创build了一个testing工作表Jia源 ，看起来像这样：

你说这些表都是一样的大小。 在这种情况下，以下代码将输出到立即窗口每个表的尺寸。 这个代码的输出是：

 Table A1:C6 Table A8:C13 Table A15:C20 

对于你的表，你需要改变常量TableHeight和TableWidth的值。 您还必须将“Jia Source”更改为源工作表的名称。

 Option Explicit Sub ExtractValue() Dim ColSrcLeft As Long Dim ColSrcRight As Long Dim RowSrcTitle As Long ' First row or table Dim RowSrcHeader As Long ' Header row of table Dim RowSrcEnd As Long ' Last row of table Const TableHeight As Long = 4 Const TableWidth As Long = 3 RowSrcTitle = 1 Do While True With Worksheets("Jia Source") If .Cells(RowSrcTitle, "A").Value = "" Then Exit Do End If RowSrcHeader = RowSrcTitle + 1 RowSrcEnd = RowSrcHeader + TableHeight ColSrcLeft = 1 ColSrcRight = ColSrcLeft + TableWidth - 1 Debug.Print "Table " & colNumToCode(ColSrcLeft) & RowSrcTitle & ":" & _ colNumToCode(ColSrcRight) & RowSrcEnd End With ' Code to handle table goes here. RowSrcTitle = RowSrcEnd + 2 Loop End Sub Function colNumToCode(ByVal colNum As Integer) As String ' Convert Excel column number to column identifier or code ' Last updated 3 Feb 12. Adapted to handle three character codes. Dim code As String Dim partNum As Integer If colNum = 0 Then colNumToCode = "0" Else code = "" Do While colNum > 0 partNum = (colNum - 1) Mod 26 code = Chr(65 + partNum) & code colNum = (colNum - partNum - 1) \ 26 Loop colNumToCode = code End If End Function 

我已经离开了代码，显示如何search表，如果他们的大小不同。 如果上面的代码不会为工作表生成正确的结果，则可能需要合并这两个例程。

以下假定RowSrcTitle，RowSrcHeader，RowSrcLast，ColSrcLeft和ColSrcRight是正确的。 它是从ExtractValue（）的代码加上将数据复制到我命名为“Jia Destination”的目标工作表的代码。 它的输出是：

玩一玩。 如果有必要回来的问题。

 Sub ExtractValue2() Dim ColDestCrnt As Long Dim ColSrcCrnt As Long Dim ColSrcLeft As Long Dim ColSrcRight As Long Dim Found As Boolean Dim RowDestBottom As Long Dim RowDestTop As Long Dim RowSrcTitle As Long ' First row or table Dim RowSrcHeader As Long ' Header row of table Dim RowSrcEnd As Long ' Last row of table Dim TableTitle As String Dim CellArray() As Variant Const TableHeight As Long = 4 Const TableWidth As Long = 3 RowSrcTitle = 1 ColDestCrnt = 1 RowDestTop = 1 RowDestBottom = RowDestTop + TableHeight Do While True With Worksheets("Jia Source") If .Cells(RowSrcTitle, "A").Value = "" Then Exit Do End If RowSrcHeader = RowSrcTitle + 1 RowSrcEnd = RowSrcHeader + TableHeight ColSrcLeft = 1 ColSrcRight = ColSrcLeft + TableWidth - 1 End With If ColDestCrnt = 1 Then ' Column 1, the list of names, has not been output. ' This assumes all tables have the same rows in the same ' sequence With Worksheets("Jia Source") ' This statement loads all the values in a range to an array in a ' single statements. Ask if you want more detail on what I am doing. ' Load name column for this table CellArray = .Range(.Cells(RowSrcHeader, ColSrcLeft), _ .Cells(RowSrcEnd, ColSrcLeft)).Value End With With Worksheets("Jia Destination") ' Clear destination sheet .Cells.EntireRow.Delete ' Write array containing name column to destination sheet .Range(.Cells(RowDestTop, 1), _ .Cells(RowDestBottom, 1)).Value = CellArray End With ColDestCrnt = ColDestCrnt + 1 End If With Worksheets("Jia Source") ' Find Value column. Found = False For ColSrcCrnt = ColSrcLeft + 1 To ColSrcRight If LCase(.Cells(RowSrcHeader, ColSrcCrnt).Value) = "value" Then Found = True Exit For End If Next End With ' If Found is False, the table has no value column and is ignored If Found Then With Worksheets("Jia Source") ' Extract title of title TableTitle = .Cells(RowSrcTitle, ColSrcLeft).Value ' Load name column (excluding header) for this table CellArray = .Range(.Cells(RowSrcHeader + 1, ColSrcCrnt), _ .Cells(RowSrcEnd, ColSrcCrnt)).Value End With With Worksheets("Jia Destination") ' Copy title .Cells(1, ColDestCrnt).Value = TableTitle ' Write array containing name column to destination sheet .Range(.Cells(RowDestTop + 1, ColDestCrnt), _ .Cells(RowDestBottom, ColDestCrnt)).Value = CellArray End With ColDestCrnt = ColDestCrnt + 1 End If RowSrcTitle = RowSrcEnd + 2 Loop End Sub 

Answer 2

回答新的问题

如果你的最后澄清是正确的，这个代码比你需要更复杂。 在发布之前，我已经创build了一个例程，能够处理比您假设需要更多的表格。 由于你没有看到“真实”的文件，我没有删除代码来处理完整的，可能的复杂性。

我创build了一个如下所示的testing工作表：

我build议你复制这个工作表，因为它包含了我能想到的所有讨厌的问题。 试试这个工作表的代码。 尝试了解代码在做什么，为什么。 那么你应该准备好任何真正的桌子扔给你。

一些代码是复杂的，我不得不定义一个用户定义的数据types。 我试着用谷歌search“用户自定义数据types”，并非常失望的教程，我发现，所以我会自己去。

假设我的macros需要为许多人保存姓名和年龄。 我将显然需要一些数组：

 Dim NameFamily() As String Dim NameGiven() As String Dim Age() As Long ReDim NameFamily(1 to 20) ReDim NameGiven(1 to 3, 1 to 20) ReDim Age(1 to 20) NameFamily(5) = "Dallimore" NameGiven(1, 5) = "Anthony" NameGiven(2, 5) = "John" NameGiven(3, 5) = "" Age(5) = 65 

你可以很容易地得到很多难以维护的代码; 特别是随着人均variables的增加。

另一种方法是使用大多数语言所称的结构，VBA调用用户定义的数据types：

 Type Person NameFamily As String NameGiven() As String NumGivenNames as Long Age As Long End Type 

Person是一个新的数据types，我可以使用这种types声明variables：

 Dim Boss As Person Dim OtherStaff() As Person ReDim OtherStaff(1 to 20) OtherStaff(5).NameFamily = "Dallimore" OtherStaff(5).NumGivenNames = 2 Redim OtherStaff(5).NameGiven(1 To OtherStaff(5).NumGivenNames) OtherStaff(5).NameGiven(1) = "Anthony" OtherStaff(5).NameGiven(2) = "John" OtherStaff(5).Age = 65 

这可能看起来不那么容易。 当你想添加另一个关于人的信息时，好处变得更加明显; 也许是几个孩子。 对于常规数组，首先必须添加一个新数组。 然后，您必须find调整人员arrays的代码中的每个点，并为新arrays添加ReDim语句。 如果你错过任何ReDim，你会得到奇怪的错误。 使用用户定义的数据types，可以在“types”定义中添加一行：

 Type Person NameFamily As String NameGiven() As String NumGivenNames as Long Age As Long NumChildren As Long End Type 

所有现有的代码现在完全更新这个新的variables。

上面是一个非常简短的介绍，但我相信它涵盖了我在代码中使用的用户定义的数据types的每个function。

我希望我已经包含足够的评论，让你了解我的代码。 缓慢地解决问题，并在必要时提出问题。

下面的代码是已更新的第三个版本，以解决早期版本的问题。

可变的命名约定

名称的forms是AaaaBbbbCccc，其中每个名称部分缩小了名称的范围。 所以“Col”是专栏的简称。 任何用作列号的variables都会启动“Col”。 “Dest”是目的地的简称，“Src”是“Source”的简称。 所以任何启动“ColSrc”的variables都是源工作表的列号。

如果我有一个数组AaaaBbbbCccc，该数组的任何索引将启动InxAaaaBbbbCccc，除非结果名称太长，在这种情况下，Aaaa，Bbbb和Cccc被缩写或丢弃。 所以“NameDtl（）”的所有索引都会启动“InxName”，因为我认为“InxNameDtl”太长了。

“Crnt”是“Current”的缩写，通常表示for循环variables或for循环的一次迭代中从数组中提取的值。

 Option Explicit Type typNameDtl InxPredCrntMax As Long Name As String Output As Boolean Predecessor() As String End Type Sub ExtractValue3() Dim ColDestCrnt As Long ' Current column of destination worksheet Dim ColSrcCrnt As Long ' Current column of source worksheet Dim ColSrcSheetLast As Long ' Last column of worksheet Dim InxNISCrnt As Long ' Current index into NameInSeq array Dim InxNISCrntMax As Long ' Index of last used entry in NameInSeq array Dim InxNISFirstThisPass As Long ' Index of first entry in NameInSeq array ' used this pass Dim InxNameCrnt As Long ' Current index into NameDtl array Dim InxNameCrntMax As Long ' Index of last used entry in NameDtl array Dim InxPredCrnt As Long ' Current index into NameDtl(N).Predecessor ' array Dim InxPredCrntMaxCrnt As Long ' Temporary copy of ' NameDtl(N).InxPredecessorCrntMax Dim InxTableCrnt As Long ' Current index into RowSrcTableTitle and ' RowSrcTableEnd arrays Dim InxTableCrntMax As Long ' Last used entry in RowSrcTableTitle and ' RowSrcTableEnd arrays Dim Found As Boolean ' Set to True if a loop finds what is ' being sought Dim NameCrnt As String ' Current index into NameDtl array Dim NameInSeq() As String ' Array of names in output sequence Dim NameLenMax As Long ' Maximum length of a name. Only used to ' align columns in diagnostic output. Dim NameDtl() As typNameDtl ' Array of names found and their predecessors Dim PredNameCrnt As String ' Current predecessor name. Used when ' searching NameDtl(N).Predecessor Dim RowDestCrnt As Long ' Current row of destination worksheet Dim RowSrcCrnt1 As Long ' \ Indices into source worksheet allowing Dim RowSrcCrnt2 As Long ' / nested searches Dim RowSrcTableEnd() As Long ' Array holding last row of each table within ' source worksheet Dim RowSrcTableEndCrnt As Long ' The last row of the current table Dim RowSrcSheetLast As Long ' Last row of source worksheet Dim RowSrcTableTitle() As Long ' Array holding title row of each table within ' source worksheet Dim RowSrcTableTitleCrnt As Long ' Title row of current table Dim SheetValue() As Variant ' Copy of source worksheet. ' Column A of source worksheet used to test this code: ' Start ' row Values in starting and following rows ' 2 block1 name cdef ' 9 block2 name bcde ' 16 block3 name acd ' 22 block4 name ade ' 29 block5 name adf ' 36 block6 name def ' Note that a and b never appear together in a table; it is impossible ' to deduce their preferred sequence from this data. ' Stage 1: Load entire source worksheet into array. ' ================================================= With Worksheets("Jia Source") ' Detrmine dimensions of worksheet RowSrcSheetLast = .Cells.Find("*", .Range("A1"), xlFormulas, , _ xlByRows, xlPrevious).Row ColSrcSheetLast = .Cells.Find("*", .Range("A1"), xlFormulas, , _ xlByColumns, xlPrevious).Column SheetValue = .Range(.Cells(1, 1), _ .Cells(RowSrcSheetLast, ColSrcSheetLast)).Value ' SheetValue is a one-based array with rows as the first dimension and ' columns as the second. An array loaded from a worksheet is always one-based ' even if the range does not start at Cells(1,1). Because this range starts ' at Cells(1,1), indices into SheetValue match row and column numbers within ' the worksheet. This match is convenient for diagnostic output but is not ' used by the macro which does not reference the worksheet, RowSrcSheetLast or ' ColSrcSheet again. End With ' Stage 2: Locate each table and store number of ' title row and last data row in arrays. ' ============================================== ' 100 entries may be enough. The arrays are enlarged if necessary. ReDim RowSrcTableEnd(1 To 100) ReDim RowSrcTableTitle(1 To 100) InxTableCrntMax = 0 ' Arrays currently empty RowSrcCrnt1 = 1 ' Loop identifying dimensions of tables Do While RowSrcCrnt1 <= RowSrcSheetLast ' Search down for the first row of a table Found = False Do While RowSrcCrnt1 <= RowSrcSheetLast If SheetValue(RowSrcCrnt1, 1) <> "" Then RowSrcTableTitleCrnt = RowSrcCrnt1 Found = True Exit Do End If RowSrcCrnt1 = RowSrcCrnt1 + 1 Loop If Not Found Then ' All tables located Exit Do End If ' Search down for the last row of a table Found = False Do While RowSrcCrnt1 <= RowSrcSheetLast If SheetValue(RowSrcCrnt1, 1) = "" Then RowSrcTableEndCrnt = RowSrcCrnt1 - 1 Found = True Exit Do End If RowSrcCrnt1 = RowSrcCrnt1 + 1 Loop If Not Found Then ' Last table extends down to bottom of worksheet RowSrcTableEndCrnt = RowSrcSheetLast End If ' Store details of this table. InxTableCrntMax = InxTableCrntMax + 1 ' Enlarge arrays if they are full If InxTableCrntMax > UBound(RowSrcTableTitle) Then ' Redim Preserve requires the interpreter find a block of memory ' of the new size, copy values across from the old array and ' release the old array for garbage collection. I always allocate ' extra memory in large chunks and use an index like ' InxTableCrntMax to record how much of the array has been used. ReDim Preserve RowSrcTableTitle(UBound(RowSrcTableTitle) + 100) ReDim Preserve RowSrcTableEnd(UBound(RowSrcTableTitle) + 100) End If RowSrcTableTitle(InxTableCrntMax) = RowSrcTableTitleCrnt RowSrcTableEnd(InxTableCrntMax) = RowSrcTableEndCrnt Loop ' Output the arrays to the Immediate window to demonstrate they are correct. ' For my test data, the output is: ' Elements: 1 2 3 4 5 6 ' Title: 2 9 16 22 29 36 ' Last data: 7 14 20 26 33 40 Debug.Print "Location of each table" Debug.Print " Elements:"; For InxTableCrnt = 1 To InxTableCrntMax Debug.Print Right(" " & InxTableCrnt, 3); Next Debug.Print Debug.Print " Title:"; For InxTableCrnt = 1 To InxTableCrntMax Debug.Print Right(" " & RowSrcTableTitle(InxTableCrnt), 3); Next Debug.Print Debug.Print "Last data:"; For InxTableCrnt = 1 To InxTableCrntMax Debug.Print Right(" " & RowSrcTableEnd(InxTableCrnt), 3); Next Debug.Print ' Stage 3. Build arrays listing predecessors of each name ' ======================================================== ' The names within the tables are all in the same sequence but no table ' contains more than a few names so that sequence is not obvious. This ' stage accumulates data from the tables so that Stage 4 can deduce the full ' sequence. More correctly, Stage 4 deduces a sequence that does not ' contradict the tables because the sequence of a and b and the sequence ' of f and g is not defined by these tables. ' For Stage 4, I need a list of every name used in the tables and, for each ' name, a list of its predecessors. Consider first the list of names. ' NameDtl is initialised to NameDtl(1 to 50) and InxNameCrntMax is initialised ' to 0 to record the array is empty. In table 1, the code below finds c, d, ' e and f. NameDtl and InxNameCrntMax are updated as these names are found: ' ' Initial state: InxNameCrntMax = 0 NameDtl empty ' Name c found : InxNameCrntMax = 1 NameDtl(1).Name = "c" ' Name d found : InxNameCrntMax = 2 NameDtl(2).Name = "d" ' Name e found : InxNameCrntMax = 3 NameDtl(3).Name = "e" ' Name f found : InxNameCrntMax = 4 NameDtl(4).Name = "f" ' In table 2, the code finds; b, c, d and e. b is new but c, d and e are ' already recorded and they must not be added again. For each name found, ' the code checks entries 1 to InxNameCrntMax. Only if the new name is not ' found, is it added. ' For each name, Stage 4 needs to know its predecessors. From table 1 it ' records that: ' d is preceeded by c ' e is preceeded by c and d ' f is preceeded by c, d and e ' The same technique is used for build the list of predecessors. The ' differences are: ' 1) Names are accumulated in NameDtl().Name while the predecessors of ' the fifth name are accumulated in NameDtl(5).Predecessor. ' 2) InxNameCrntMax is replaced, for the fifth name, by ' NameDtl(5).InxPredCrntMax. ' Start with space for 50 names. Enlarge if necessary. ReDim NameDtl(1 To 50) InxNameCrntMax = 0 ' Array is empty ' For each table For InxTableCrnt = 1 To InxTableCrntMax RowSrcTableTitleCrnt = RowSrcTableTitle(InxTableCrnt) RowSrcTableEndCrnt = RowSrcTableEnd(InxTableCrnt) ' For each data row in the current table For RowSrcCrnt1 = RowSrcTableTitleCrnt + 2 To RowSrcTableEndCrnt ' Look in NameDtl for name from current data row NameCrnt = SheetValue(RowSrcCrnt1, 1) Found = False For InxNameCrnt = 1 To InxNameCrntMax ' Not this comparison is case sensitive "John" and "john" would not ' match. Use LCase if case insensitive comparison required. If NameCrnt = NameDtl(InxNameCrnt).Name Then Found = True Exit For End If Next If Not Found Then ' This is a new name. Create entry in NameDtl for it. InxNameCrntMax = InxNameCrntMax + 1 If InxNameCrntMax > UBound(NameDtl) Then ReDim Preserve NameDtl(UBound(NameDtl) + 50) End If InxNameCrnt = InxNameCrntMax NameDtl(InxNameCrnt).Output = False NameDtl(InxNameCrnt).Name = NameCrnt ' Allow for up to 20 predecessors ReDim NameDtl(InxNameCrnt).Predecessor(1 To 20) NameDtl(InxNameCrnt).InxPredCrntMax = 0 End If ' Check that each predecessor for the current name within the ' current table is recorded against the current name For RowSrcCrnt2 = RowSrcTableTitleCrnt + 2 To RowSrcCrnt1 - 1 Found = False PredNameCrnt = SheetValue(RowSrcCrnt2, 1) ' Move current number of predecessors from array to variable ' to make code more compact and easier to read InxPredCrntMaxCrnt = NameDtl(InxNameCrnt).InxPredCrntMax For InxPredCrnt = 1 To InxPredCrntMaxCrnt If PredNameCrnt = _ NameDtl(InxNameCrnt).Predecessor(InxPredCrnt) Then Found = True Exit For End If Next If Not Found Then ' This predecessor has not been recorded against the current name InxPredCrntMaxCrnt = InxPredCrntMaxCrnt + 1 If InxPredCrntMaxCrnt > _ UBound(NameDtl(InxNameCrnt).Predecessor) Then ReDim Preserve NameDtl(UBound(NameDtl) + 20) End If NameDtl(InxNameCrnt).Predecessor(InxPredCrntMaxCrnt) = PredNameCrnt ' Place new value for number of predecessors in its permenent store. NameDtl(InxNameCrnt).InxPredCrntMax = InxPredCrntMaxCrnt End If Next Next Next ' Output NameDtl to the Immediate window to demonstrate it is correct. ' Find length of longest name so columns can be justified NameLenMax = 4 ' Minimum length is that of title For InxNameCrnt = 1 To InxNameCrntMax If Len(NameDtl(InxNameCrnt).Name) > NameLenMax Then NameLenMax = Len(NameDtl(InxNameCrnt).Name) End If Next ' Output headings Debug.Print vbLf & "Contents of NameDtl table" Debug.Print Space(NameLenMax + 10) & "Max" Debug.Print Left("Name" & Space(NameLenMax), NameLenMax + 2) & _ "Output inx Predecessors" ' Output table contents For InxNameCrnt = 1 To InxNameCrntMax Debug.Print Left(NameDtl(InxNameCrnt).Name & Space(NameLenMax), _ NameLenMax + 4) & _ IIf(NameDtl(InxNameCrnt).Output, " True ", " False") & _ " " & Right(" " & _ NameDtl(InxNameCrnt).InxPredCrntMax, 3) & " "; For InxPredCrnt = 1 To NameDtl(InxNameCrnt).InxPredCrntMax Debug.Print " " & _ NameDtl(InxNameCrnt).Predecessor(InxPredCrnt); Next Debug.Print Next ' Stage 4: Sequence names for list. ' ================================= ' The output from the above routine for the test data is: ' Max ' Name Output inx Predecessors ' c False 2 ba ' d False 3 cba ' e False 4 cdba ' g False 3 cde ' b False 0 ' a False 0 ' f False 3 ade ' Note 1: All this information is in the sequence found. ' Note 2: We do not know the "true" sequence of b and a or of g and f. ' The loop below has three steps: ' 1) Transfer any names to NamesInSeq() that have not already been ' transferred and have a value of 0 for Max inx. ' 2) If no names are transferred, the loop has completed its task. ' 3) Remove any names transferred during this pass from the predecessor ' lists and mark the name as output. ' Before the loop NameInSeq() is empty, InxNISCrntMax = 0 and ' InxNISFirstThisPass = InxNISCrntMax+1 = 1. ' After step 1 of pass 1: ' NameInSeq(1) = "b" and NameInSeq(2) = "a" ' InxNISCrntMax = 2 ' Entries InxNISFirstThisPass (1) to InxNISCrntMax (2) of NamesInSeq have ' been transferred during this pass so names a and b are removed from the ' lists by copying the last entry in each list over the name to be removed ' and reducing Max inx. For pass 1, only the list for f is changed. ' At the end of pass 1, NameDtl is: ' Max ' Name Output inx Predecessors ' c False 0 ' d False 1 c ' e False 2 cd ' g False 3 cde ' b True 0 ' a True 0 ' f False 2 ed ' During pass 2, c is moved to NamesInSeq and removed form the lists to give: ' Max ' Name Output inx Predecessors ' c True 0 ' d False 0 ' e False 1 d ' g False 2 ed ' b True 0 ' a True 0 ' f False 2 ed ' This process continues until all names have been transferred. ' Size array for total number of names. ReDim NameInSeq(1 To InxNameCrntMax) InxNISCrntMax = 0 ' Array empty ' Loop until every name has been moved ' from ProdecessorDtl to NameInSeq. Do While True Found = False ' No name found to move during this pass ' Record index of first name, if any, to be added during this pass InxNISFirstThisPass = InxNISCrntMax + 1 ' Transfer names without predecessors to NameInSeq() For InxNameCrnt = 1 To InxNameCrntMax If Not NameDtl(InxNameCrnt).Output Then ' This name has not been output If NameDtl(InxNameCrnt).InxPredCrntMax = 0 Then ' This name has no predecessors or no predecessors that ' have not already been transferred to NameInSeq() InxNISCrntMax = InxNISCrntMax + 1 NameInSeq(InxNISCrntMax) = NameDtl(InxNameCrnt).Name NameDtl(InxNameCrnt).Output = True Found = True End If End If Next If Not Found Then ' All names already transferred to NameInSeq Exit Do End If ' Remove references to names transferred to NameinSeq() ' during this pass For InxNISCrnt = InxNISFirstThisPass To InxNISCrntMax NameCrnt = NameInSeq(InxNISCrnt) For InxNameCrnt = 1 To InxNameCrntMax If Not NameDtl(InxNameCrnt).Output Then ' This name has not been output For InxPredCrnt = 1 To NameDtl(InxNameCrnt).InxPredCrntMax If NameCrnt = _ NameDtl(InxNameCrnt).Predecessor(InxPredCrnt) Then ' Remove this name by overwriting it ' with the last name in the list NameDtl(InxNameCrnt).Predecessor(InxPredCrnt) = _ NameDtl(InxNameCrnt).Predecessor _ (NameDtl(InxNameCrnt).InxPredCrntMax) NameDtl(InxNameCrnt).InxPredCrntMax = _ NameDtl(InxNameCrnt).InxPredCrntMax - 1 Exit For End If Next End If Next Next Loop Debug.Print vbLf & "Name list" For InxNISCrnt = 1 To InxNISCrntMax Debug.Print NameInSeq(InxNISCrnt) Next ' Stage 5: Transfer data ' ====================== ' We now have everything we need for the transfer: ' * NameInSeq() contains the names in the output sequence ' * SheetValue() contains all the data from the source worksheet ' * RowSrcTableTitle() and RowSrcTableEnd() identify the ' start and end row of each table With Worksheets("Jia Destination") .Cells.EntireRow.Delete ' Clear destination sheet ColDestCrnt = 1 .Cells(1, ColDestCrnt).Value = "Name" ' Output names RowDestCrnt = 2 For InxNISCrnt = 1 To InxNISCrntMax .Cells(RowDestCrnt, ColDestCrnt).Value = NameInSeq(InxNISCrnt) RowDestCrnt = RowDestCrnt + 1 Next ' Output values from each table For InxTableCrnt = 1 To InxTableCrntMax RowSrcTableTitleCrnt = RowSrcTableTitle(InxTableCrnt) RowSrcTableEndCrnt = RowSrcTableEnd(InxTableCrnt) ' Find value column, if any Found = False ColSrcCrnt = 2 Do While SheetValue(RowSrcTableTitleCrnt + 1, ColSrcCrnt) <> "" If LCase(SheetValue(RowSrcTableTitleCrnt + 1, ColSrcCrnt)) = _ "value" Then Found = True Exit Do End If ColSrcCrnt = ColSrcCrnt + 1 Loop If Found Then ' Value column found for this table ColDestCrnt = ColDestCrnt + 1 ' Transfer table name .Cells(1, ColDestCrnt).Value = SheetValue(RowSrcTableTitleCrnt, 1) ' Transfer values RowDestCrnt = 2 RowSrcCrnt1 = RowSrcTableTitleCrnt + 2 For InxNISCrnt = 1 To InxNISCrntMax If NameInSeq(InxNISCrnt) = SheetValue(RowSrcCrnt1, 1) Then ' Value for this name in this table .Cells(RowDestCrnt, ColDestCrnt).Value = _ SheetValue(RowSrcCrnt1, ColSrcCrnt) ' Value transferred from this row. Step to next if any RowSrcCrnt1 = RowSrcCrnt1 + 1 If RowSrcCrnt1 > RowSrcTableEndCrnt Then ' No more rows in this table Exit For End If End If RowDestCrnt = RowDestCrnt + 1 Next Else Call MsgBox("Table starting at row " & RowSrcTableTitleCrnt & _ " does not have a value column", vbOKOnly) End If Next End With End Sub