我有几张结构不同的图纸，我需要使用一些常见的列标题进行合并 我在一个工作表（“ Combine”）中收集了常见的标头，并试图编写一个宏以查找同一列，并将其数据写入合并工作表，该宏仅获取第一列，而没有进行处理。
任何与此问题有关的指导
Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Sht As Worksheet ' Every Sheet on This Workbook
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
II = 2 ' Start on row 2 - Sheet1 & Sheet2
XX = 2 ' Start on row 2 - Combine sheet
'Looping through the worksheets in the workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
For ZZ = 1 To 100
For I = 1 To 100
If Sheets(Sht.Name).Cells(1, I).Value = Comb.Cells(1, ZZ).Value Then
Do Until IsEmpty(Sht.Columns(1).Cells(II))
Comb.Cells(XX, ZZ).Value = Sheets(Sht.Name).Cells(II, I).Value
II = II + 1
XX = XX + 1
Loop
End If
Next I
I = 1
Next ZZ
End If
II = 2 ' Reset 1st Loop to capture the new sheet data
Next
答案 0 :(得分：0)
如果我正确理解了您的问题，则您有多个工作表，其中的标题行有一定数量的列。然后，您可以在下面的相应列中找到数据行。
您已经查看了每个工作表中的标题，并添加了称为“合并”的工作表中常用的名称。在“合并”表上找不到所有工作表上的所有列。合并表是工作簿中总列名的子集。
这些表可能包含来自多个测试运行或其他任何数据。输出可能包含公用列以及一些其他数据。例如，工作表1可以包含日期，时间，位置和结果。表格2可以包含日期，时间和测试器。
您需要一个组合表来显示常用字段，在这种情况下为日期，时间，结果和测试器。您已经确定了常用标题。
我认为您的问题可能出在Do Until IsEmpty(Sht.Columns(1).Cells(II))。您可能遇到了一个空单元格。
此外，使用Excel的内置函数来在工作表之间移动大型数据块要快得多。
鉴于您似乎正在学习VBA并做了相当不错的尝试，我自由地为您提供了一个示例，该示例使用了更高级的方法来解决问题
以下代码实际上将来自每个工作表和公共列的数据连接到“合并”工作表。如果某列没有数据表，则会保留空白，这些数据将被复制到“合并”列中。这意味着基于源数据表，“结果”和“测试”列下将有空白单元格。
我希望这对您有所帮助，并且可以回答您的问题。我从本网站上其他人的例子中学到了很多，并且正在尝试将其付清。
Option Explicit
Public Sub Tester()
'Not needed
'Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
'Declare a range object and assign it to contain column names
'from Combine. This range, converted to a list
'below will compare the combined heading names with
'each column heading on each sheet.
Dim rngCombineHeadings As Range
'set combine headings into the range using the function
'EndOfRangeColumn, which is decribed below
Set rngCombineHeadings = EndOfRangeColumn(Comb.Range("A1"))
'Declare a collection to be used in the for loop to compare
'Combine column headings with each source sheets headings
'Only copy those columns that match
Dim colCombinedHeadings As Collection
'Get a collection (aka list of strings) of the column headings
Set colCombinedHeadings = GetCommonHeadings(rngCombineHeadings)
'Declare two ranges to be used as the index inside
'for loops below.
Dim combineColTargetRng As Range
Dim colRng As Range
'Declare a variant to used use the index for looing
'through the Combine sheet headings
Dim vHeading As Variant
'Declare tblRng. It will be set to contain the entire data table
'on each sheet. Row 1 contains the headings, rows 2 - n contain
'the data that may be moved.
Dim tblRng As Range
'This is the range that will be manipulated and copied
'to the Combine sheet
Dim copyRng As Range
'Looping through the worksheets in the workbook
'Index variable used in for each loop below best practice is
'declare you variables near where they are used.
Dim Sht As Worksheet ' Every Sheet on This Workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
'Set the data table to the tblRng object.
Set tblRng = EndOfRangeRow(Sht.Range("A1"))
Set tblRng = EndOfRangeColumn(tblRng)
'For each sheet, loop through each headings on
'the Combined sheet and compare those to the
'headings on the data table on the current sheet
For Each vHeading In colCombinedHeadings
For Each colRng In tblRng.Columns
'if the heading on Combined = the current
'columns heading then, copy the data
'to the combined sheet.
If vHeading = colRng.Value2(1, 1) Then
'Resize the copy range to exclude the heading row
'and to reduce the size by one row, reflecting removal
'of the header row from the range
Set copyRng = ResizeTheRange(colRng.Offset(1, 0))
'Find the column on the Combine sheet that
'matches the current value in vHeading
Set combineColTargetRng = rngCombineHeadings.Find(colRng.Value2(1, 1))
'Copy the current sheet-current column to the clipboard
copyRng.Copy
'The if statement below determines if this is the first
'column of data being copied to the Combine sheet
'if it is, the row 2 current column is empty
'otherwise it has a value and we need to move the paste point
'to the end of the current Combine sheet column
If combineColTargetRng.Offset(1, 0).Value2 = "" Then
Set combineColTargetRng = combineColTargetRng.Offset(1, 0)
Else
Set combineColTargetRng = EndOfRangeRow(combineColTargetRng)
Set combineColTargetRng = _
combineColTargetRng.Offset( _
combineColTargetRng.Rows.Count, 0)
End If
'Paste the values copied from the current sheet
'that are under the same column heading as on the combined sheet
'There are a number of options for pasteSpecial
'See https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial
combineColTargetRng.PasteSpecial Paste:=xlPasteAll
End If
Next
Next
End If
Next
End Sub
'*****************************************************************************
'**
'** This function demonstrates use of the ParamArray. It enables the
'** calling routine, to provide the range as an Excel Range, a Collection
'** an Array, or a list of strings.
'**
'** Calling the Function:
'** Dim aCol as Collection
'** Set aCol = GetCommonHeadings(aCol)
'** Dim rngExcelRange as Range
'** set rngExcelRange = Range("A1:X1")
'** Set aCol = GetCommonHeadings(rngExcelRange)
'** Dim vArr() as Variant
'** vArr = Array("H1", "H2", "H3", "H4")
'** Set aCol = GetCommonHeadings(vArr)
'** Set aCol = GetCommonHeadings("Title1", "Title2", "Title3", "Title4")
Public Function GetCommonHeadings(ParamArray mRange() As Variant) As Collection
'Instantiate the return collection
Dim retVal As New Collection
Dim nDx As Long
If UBound(mRange) < 0 Then
'Cannot do anything without the heading range
Set retVal = Nothing
ElseIf TypeOf mRange(0) Is Range Then
'Heading Range is an Excel Range
Dim rngMaster As Range
Dim colRng As Range
Set rngMaster = mRange(0)
For Each colRng In rngMaster.Columns
retVal.Add colRng.Value2
Next
ElseIf TypeOf mRange(0) Is Collection Then
'Heading Range is a collection of text strings
Set retVal = mRange(0)
ElseIf VarType(mRange(0)) = vbArray + vbVariant Then
'Heading Range passed is an array of strings
Dim varArr() As Variant
varArr = mRange(0)
For nDx = 0 To UBound(varArr)
retVal.Add varArr(nDx)
Next
ElseIf VarType(mRange(0)) = vbString Then
'mRange contains an array of strings
For nDx = 0 To UBound(mRange)
retVal.Add mRange(nDx)
Next
Else
Set retVal = Nothing
End If
Set GetCommonHeadings = retVal
End Function
'****************************************************************************
'**
'** The Functions EndOfRangeColumn, EndOfRangeRow, StartOfRangeColumn, and
'** StartOfRangeRow take one parameter which is an Excel Range. Based on
'** the funtions name it will return the cell that is at the other end.
'** These are just wrappers to make the code more readable. The real work
'** is done by the Private Function GetRangeAtEnd. The private function
'** takes an Excel Range and the direction you want to move.
Public Function EndOfRangeColumn(ByRef mStartOfRange As Range) As Range
Set EndOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToRight)
End Function
Public Function EndOfRangeRow(ByRef mStartOfRange As Range) As Range
Set EndOfRangeRow = GetRangeAtEnd(mStartOfRange, xlDown)
End Function
Public Function StartOfRangeColumn(ByRef mEndOfRange As Range) As Range
Set StartOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToLeft)
End Function
Public Function StartOfRangeRow(ByRef mEndOfRange As Range) As Range
Set StartOfRangeRow = GetRangeAtEnd(mStartOfRange, xlUp)
End Function
Private Function GetRangeAtEnd(ByRef mRange As Range, ByVal mDirection As XlDirection) As Range
Set GetRangeAtEnd = Range(mRange, mRange.End(mDirection))
End Function
'***************************************************************
'**
'** The Private Function ResizeTheRange takes an Excel range
'** provide in the parameter. In effect it removes the first
'** row from the provided range, and reduces the size by one.
Private Function ResizeTheRange(ByRef mRange As Range) As Range
Dim retVal As Range
Set retVal = mRange.Offset(1, 0)
Set retVal = retVal.Resize(retVal.Rows.Count - 1, 1)
Set retVal = EndOfRangeRow(retVal)
Set ResizeTheRange = retVal
End Function