回答新问题
如果您的最终说明是正确的，则此代码比您需要的要复杂。在您发布之前，我已经创建了一个例程，能够处理比您想象的更多的表格。由于您没有看到“真实”文件，因此我没有删除代码来处理完整的、可能的复杂性。
我创建了一个这样的测试工作表：
我建议你复制这个工作表，因为它包含了我能想到的每一个讨厌的问题。使用此工作表试用此代码。尝试了解代码在做什么以及为什么。然后，您应该为真正的桌子扔给您的任何事情做好准备。
有些代码很复杂，我必须定义一个用户定义的数据类型。我尝试用谷歌搜索“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”是column的缩写。任何用作列号的变量都以“Col”开头。“Dest”是目标的缩写，“Src”是“源”的缩写。因此，任何以“ColSrc”开头的变量都是源工作表的列号。
如果我有一个数组 AaaaBbbbCccc，那么该数组的任何索引都将以 InxAaaaBbbbCccc 开头，除非结果名称太长，在这种情况下 Aaaa、Bbbb 和 Cccc 被缩写或丢弃。所以“NameDtl()”的所有索引都以“InxName”开头，因为我认为“InxNameDtl”太长了。
“Crnt”是“Current”的缩写，通常表示 for 循环变量或从数组中提取的值，用于 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 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
