宏提取数据块

Question

我一整天都在解决这个问题而无法解决。

输入数据由几个具有相同行数和列数的数据块组成。每个数据块的名称都在块的第一行。此外，他们进一步分开一排空白。

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填写这些表中的相应单元格？即新输入如下：

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

如何提取值及其相应的分数并将它们放入一个单元格？像这样：代码表明该值被放入动态数组中。然后将.range分配给此数组。我的第一个想法是构造另一个数组来存储“得分”列的值。然后循环遍历两个数组中的每个元素，并将它们连接在一起。但是，似乎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

第一个答案 - 问题简介和澄清要求

这不是解决方案 - 您没有为解决方案提供足够的信息 - 但介绍了问题和可能的技术。警告：我在NotePad中输入了这个;不保证没有语法错误。

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

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

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是VBA，相当于将光标放在行RowCrnt + 1的最后一列，然后单击Control + Left。这可能是查找表1中最后一个使用列的最简单方法。

Control + ArrowKey沿指示的方向移动光标并：

• 如果当前单元格为空白，则停在第一个非空白单元格
• 如果当前单元格为非空白​​，则下一个单元格是空白单元格之前的最后一个非空白单元格，
• 如果当前单元格为非空白​​但下一个单元格为空白，则停在下一个非空白单元格中，
• 如果没有符合上述条件的单元格，则在范围结束时停止。

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

如果表格之间的空白行数可能有所不同，我认为以下将是查找每个表格的最简单方法：

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”列？ Value列始终是最后一列吗？如果没有，则必须在标题行中搜索列名称。

每张桌子的顺序是否相同？如果没有，你将不得不对它们进行排序。每个表都包含每一行吗？如果没有，您组合表的代码必须允许这样做。

我希望上面的内容能让你开始。如果您有具体问题，请回来。

第二个答案 - 对澄清的回应

我创建了一个测试工作表 Jia Source ，如下所示：

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

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

我已经离开了代码，该代码显示了如果表的大小不同，如何搜索表。如果上面的代码没有为您的工作表生成正确的结果，您可能需要合并这两个例程。

以下假设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

回答新问题

如果您的最终说明是正确的，那么此代码比您需要的更复杂。在你发布它之前，我创建了一个例程，能够处理比你想象的更多变化的表。由于您还没有看到“真实”文件，我没有删除代码来处理完整的，可能的复杂性。

我创建了一个这样的测试工作表：

我建议你复制这个工作表，因为它包含了我能想到的每一个令人讨厌的问题。使用此工作表尝试此代码。尝试了解代码正在做什么以及为什么。那么你应该准备好真正的桌子扔给你的任何东西。

有些代码很复杂，我必须定义用户定义的数据类型。我尝试使用谷歌搜索“vba用户定义的数据类型”，并对我发现的教程非常失望，所以我将自己去。

假设我的宏需要保留一些人的姓名和年龄。我显然需要一些数组：

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

您可以很容易地获得许多难以维护的代码;特别是随着每个人的变量数量的增加。

另一种方法是使用大多数语言称为结构的东西，VBA调用用户定义的数据类型：

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

Person 是一种新的数据类型，我可以使用这种类型声明变量：

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

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

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

现在，所有现有代码都已针对此新变量进行了全面更新。

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

我希望我已经包含了足够的评论，以便您了解我的代码。慢慢解决，必要时提问。

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

变量命名约定

名称的格式为AaaaBbbbCccc，其中每个名称部分都缩小了名称的范围。所以“Col”是专栏的缩写。用作列号的任何变量都以“Col”开头。 “Dest”是目的地的缩写，“Src”是“Source”的缩写。因此，任何以“ColSrc”开头的变量都是源工作表的列号。

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

“Crnt”是“Current”的缩写，通常表示for循环变量或从for-loop的一次迭代中提取的值。

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  c  d  e  f
  '      9      block2  name  b  c  d  e
  '     16      block3  name  a  c  d
  '     22      block4  name  a  d  e
  '     29      block5  name  a  d  f
  '     36      block6  name  d  e  f

  ' 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   b  a
  '  d     False    3   c  b  a
  '  e     False    4   c  d  b  a
  '  g     False    3   c  d  e
  '  b     False    0
  '  a     False    0
  '  f     False    3   a  d  e

  ' 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   c  d
  '  g     False    3   c  d  e
  '  b      True    0
  '  a      True    0
  '  f     False    2   e  d

  ' 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   e  d
  '  b      True    0
  '  a      True    0
  '  f     False    2   e  d

  ' 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