macro extract data block - vba

Question

I have worked on this problem for my entire day and can't solve it.
The input data consists of several data blocks with the same number of rows and columns. Each data block has its name in the first line within the block. Besides, they are further separated by a blank row.
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
The desired output is to extract the name and value column of each block, and then parallel them in columns. Like this:
value block1 block2 block3
a 3 6 4
b 5 8 8
c 6 6 9
Thanks for your help!
UPDATE
Thanks for your answer, Tony, and others!
I just have another requirement. It is possible that some row in some tables are missing. In other words, as you mentioned previously, the row number may vary. Is it possible to fill in the corresponding cell in these tables with NA? i.e. the new input is like:
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
The desired output now is like this:
value block1 block2 block3
a 3 6 4
b NA 8 8
c 6 6 NA
UPDATE on Jul.3 (If it's inappropriate to make the question too long, I will move this part and make it a new 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
How can I pull both the value and its corresponding score and put them into one cell? Like this: The code indicates that the value is put into an dynamic array. Then the .range is assigned to this array. My first thought is to construct another array to store the value of the "score" column. Then loop through each element in both array, and concatenate them together. However, it seems that VBA does allow me to loop through the array, since its dimension is not defined. I tried REDIM, but it did not work.
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

First answer - introduction to issues and request for clarification
This is not a solution - you do not give enough information for a solution - but introduces the issues and possible techniques. Warning: I have typed this into NotePad; no guarantees that there are no syntax errors.
You say each table is the same size although I assume not 3x3. But if they were 3x3, could I say table 1 starts in row 1, table 2 starts in row 7 and table N starts in 6(N-1)+1? That is, can you calculate the position of each table or do you need to search?
If you need to search, the following might help:
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 is the VBA equivalent of placing the cursor in the last column of row RowCrnt+1 and then clicking Control+Left. This is probably the easiest way of finding the last used column in table 1.
Control+ArrowKey moves the cursor in the indicated direction and:
if the current cell is blank, stops at the first non-blank cell,
if the current cell is non-blank and so is the next, stops at the last non-blank cells before a blank cell,
if the current cell is non-blank but the next cell is blank, stops at the next non-blank cell,
if no cell meets the above criteria, stops at the end of range.
Experiment and the above will become clearer.
If the number of blank lines between tables might vary, I think the following will be the easiest method of locating each table:
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
Within the above loop we have: Process table RowSrcTableTitle to RowSrcTableLast.
Is the Name column always column "A"? Is the Value column always the last column? If not, you will have to search across the header row for the column names.
Is every table in the same sequence? If not, you will have to sort them. Does every table contain every row? If not, your code for combining the tables will have to allow for this.
I hope the above gets you started. Come back if you have specific questions.
Second answer - Response to clarification
I created a test worksheet Jia Source which looks like this:
You say that the tables are all the same size. In this situation, the following code outputs to the Immediate Window the dimensions of each table. The output from this code is:
Table A1:C6
Table A8:C13
Table A15:C20
For your tables you will need to change the values of constants TableHeight and TableWidth. You will also have to change "Jia Source" to the name of your source worksheet.
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
I have left the code that shows how to search for the tables if they vary in size. If the above code does not produce the correct results for your worksheet, you may need to merge the two routines.
The following assumes RowSrcTitle, RowSrcHeader, RowSrcLast, ColSrcLeft and ColSrcRight are correct. It is the code from ExtractValue() plus the code to copy the data to the destination sheet which I have named "Jia Destination". Its output is:
Have a play. Come back with questions if necessary.
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

Answer to new question
If your final clarification is correct, this code is more complicated than you need. Before you posted it I had created a routine capable of handling much more varied tables than you assume you need. Since you have not seen the "real" files, I have not removed the code to handle the full, possible complexity.
I creates a test worksheet like this:
I suggest you duplicate this worksheet since it contains every nasty problem I could think of. Try out this code with this worksheet. Try to understand what the code is doing and why. You should then be ready for anything the real tables throw at you.
Some of the code is complex and I had to define a User-Defined Data Type. I tried googling "vba User-Defined Data Type" and was very disappointed by the tutorials I found so I will have a go myself.
Suppose my macro needs to hold name and age for a number of people. I will clearly need some arrays:
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
You can very easily end up with a lot of code that can be difficult to maintain; particularly as the number of variables per person increases.
The alternative is to use what most languages call a structure and VBA calls a user-defined data type:
Type Person
NameFamily As String
NameGiven() As String
NumGivenNames as Long
Age As Long
End Type
Person is a new data type and I can declare variables using this type:
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
This probably does not look any easier. The benefits become more obvious when you want to add another item of information about people; perhaps number of children. With regular arrays, you first have to add a new array. You then have to find every point within the code where you resize the person arrays and add a ReDim statement for the new array. You get strange errors if you miss any ReDim. With the user defined data types, you add one line to the Type definition:
Type Person
NameFamily As String
NameGiven() As String
NumGivenNames as Long
Age As Long
NumChildren As Long
End Type
All existing code is now fully updated for this new variable.
The above is a very brief introduction but I believe it covers every feature of user-defined data types that I used in the code.
I hope I have included enough comments to allow you to understand my code. Work through it slowly and ask questions if necessary.
The code below is a third version having been updated to address questions on the earlier versions.
Variable naming conventions
Names are of the form AaaaBbbbCccc where each name part reduces the scope of name. So "Col" is short for column. Any variable used as a column number starts "Col". "Dest" is short for destination and "Src" is short for "Source". So any variable starting "ColSrc" is a column number for the source worksheet.
If I have an array AaaaBbbbCccc, any indices for that array will start InxAaaaBbbbCccc unless the resulting name is too long in which case Aaaa, Bbbb and Cccc are abbreviated or discarded. So all indices for "NameDtl()" start "InxName" because I think "InxNameDtl" is too long.
"Crnt" is short for "Current" and typically indicates a for-loop variable or a value extracted from an array for one iteration of a 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