vba - マクロ抽出データブロック

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

値とそれに対応するスコアの両方を取得して1つのセルに入れるにはどうすればよいですか？このように：コードは、値が動的配列に入れられることを示しています。次に、.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これは、行RowCrnt + 1の最後の列にカーソルを置き、Control+Leftをクリックするのと同等のVBAです。これは、表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」ですか？[値]列は常に最後の列ですか？そうでない場合は、ヘッダー行全体で列名を検索する必要があります。

すべてのテーブルは同じ順序ですか？そうでない場合は、それらを並べ替える必要があります。すべてのテーブルにすべての行が含まれていますか？そうでない場合、テーブルを結合するためのコードはこれを考慮に入れる必要があります。

上記があなたを始めることを願っています。特定の質問がある場合は、戻ってきてください。

2番目の答え-説明への応答

次のようなテストワークシートJiaSourceを作成しました。

あなたはテーブルがすべて同じサイズであると言います。この場合、次のコードは各テーブルの寸法をイミディエイトウィンドウに出力します。このコードからの出力は次のとおりです。

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

テーブルの場合、定数TableHeightとTableWidthの値を変更する必要があります。また、「JiaSource」をソースワークシートの名前に変更する必要があります。

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

テーブルのサイズが異なる場合にテーブルを検索する方法を示すコードを残しました。上記のコードでワークシートの正しい結果が得られない場合は、2つのルーチンをマージする必要があります。

以下は、RowSrcTitle、RowSrcHeader、RowSrcLast、ColSrcLeft、およびColSrcRightが正しいことを前提としています。これは、ExtractValue（）からのコードと、「JiaDestination」という名前の宛先シートにデータをコピーするためのコードです。その出力は次のとおりです。

遊びましょう。必要に応じて質問をして戻ってきてください。

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

新しい質問への回答

最終的な説明が正しければ、このコードは必要以上に複雑になります。あなたがそれを投稿する前に、私はあなたが必要と思っているよりもはるかに多様なテーブルを処理できるルーチンを作成しました。「実際の」ファイルを見たことがないので、考えられる完全な複雑さを処理するためのコードを削除していません。

次のようなテストワークシートを作成します。

このワークシートには、私が考える可能性のあるすべての厄介な問題が含まれているため、複製することをお勧めします。このワークシートでこのコードを試してください。コードが何をしているのか、そしてその理由を理解するようにしてください。そうすれば、実際のテーブルがあなたに投げかけるものすべてに備える必要があります。

一部のコードは複雑で、ユーザー定義のデータ型を定義する必要がありました。「vbaUser-DefinedDataType」をグーグルで検索してみましたが、見つけたチュートリアルに非常に失望したので、自分で試してみます。

私のマクロが多くの人々の名前と年齢を保持する必要があると仮定します。私は明らかにいくつかの配列が必要になります：

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

これはおそらく簡単には見えません。人々に関する別の情報項目を追加したい場合、利点はより明白になります。おそらく子供の数。通常のアレイでは、最初に新しいアレイを追加する必要があります。次に、person配列のサイズを変更し、新しい配列のReDimステートメントを追加するコード内のすべてのポイントを見つける必要があります。ReDimを見逃すと、奇妙なエラーが発生します。ユーザー定義のデータ型を使用して、型定義に1行追加します。

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

これで、既存のすべてのコードがこの新しい変数に対して完全に更新されます。

上記は非常に簡単な紹介ですが、コードで使用したユーザー定義のデータ型のすべての機能を網羅していると思います。

私のコードを理解できるように、十分なコメントを含めたことを願っています。ゆっくりと作業し、必要に応じて質問してください。

以下のコードは、以前のバージョンの質問に対処するために更新された3番目のバージョンです。

変数の命名規則

名前の形式はAaaaBbbbCcccで、各名前部分によって名前の範囲が縮小されます。したがって、「Col」は列の略です。列番号として使用される変数はすべて「Col」で始まります。「Dest」はdestinationの略で、「Src」は「Source」の略です。したがって、「ColSrc」で始まる変数は、ソースワークシートの列番号です。

配列AaaaBbbbCcccがある場合、結果の名前が長すぎる場合を除いて、その配列のインデックスはInxAaaaBbbbCcccで始まります。長すぎる場合は、Aaaa、Bbbb、およびCcccが省略または破棄されます。したがって、「InxNameDtl」が長すぎると思うので、「NameDtl（）」のすべてのインデックスは「InxName」で始まります。

「Crnt」は「Current」の略で、通常、forループ変数またはforループの1回の反復で配列から抽出された値を示します。

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