Ответ на новый вопрос
Если окончательное прояснение правильно, этот код является более сложным, чем вам нужно. Прежде чем вы опубликовали его, я создал рутину, способную обрабатывать гораздо более разнообразные таблицы, чем вы предполагаете. Поскольку вы не видели «реальные» файлы, я не удалял код, чтобы справиться с полной и возможной сложностью.
I создает тестовую таблицу, как это:
Я предлагаю вам дублировать эту таблицу, поскольку она содержит всю неприятную проблему, которую я мог думать. Попробуйте этот код с этим листом. Попытайтесь понять, что делает код и почему. Затем вы должны быть готовы ко всему, что бросают на вас реальные столы.
Некоторые из кода сложны, и я должен был определить тип данных, заданный пользователем. Я попробовал googling «vba User-Defined Data Type» и был очень разочарован учебниками, которые я нашел, поэтому я сам поеду.
Предположим, что у моего макроса должно быть имя и возраст для нескольких людей. Я, безусловно, потребуется несколько массивов:
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-loop или значение, выделенное из массива для одной итерации цикла 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
строки всегда одинаковые? или вам нужна сортировка? Является ли это одной задачей или требуется ypu макрос, который может быть запущен при изменении количества строк/столбцов? – Johanness
Я смущен и сделал мой код действительно грязным. Я собираюсь извлечь столбец «значение» для всех таблиц и изменить их, разделив этот столбец на количество строк. – Jia
Мой ответ может быть продлен достаточно легко. Однако имеет ли смысл последовательность имен? Если имена были в последовательности, найденной в вашем примере, они были бы a-c-b. Вы действительно хотите Не применимо к выходу; Я бы оставил ячейку пустой для отсутствующих значений. –