VBA Excel使用常用的组合图纸标题合并多个不同的结构图纸

我有几个具有不同结构的工作表，需要使用一些常见的列标题进行合并 我在一张工作表（“Combine”）中收集了常用的标题，并试图编写一个宏来查找相同的列，并将其数据写入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

尺寸II%，XX%，ZZ%，I%'尺寸尽可能长
将Sht设置为工作表“此工作簿上的每张工作表”
将梳子调整为工作表的合并表
Set Comb=此工作簿。工作表（“合并”）
II=2'从第2排开始-活页1和活页2
XX=2'从第2行开始-联合收割机板材
'在工作簿中的工作表中循环
用于此工作簿中的每个Sht。工作表
'忽略工作表“合并”和“Val”
如果短名称为“Combine”和短名称为“Val”，则
对于ZZ=1至100
对于I=1到100
如果表（Sht.Name）.Cells（1，I）.Value=Comb.Cells（1，ZZ）.Value那么
直到空为止（第1列第2单元）
梳状单元格（XX，ZZ）.Value=表格（Sht.Name）.Cells（II，I）.Value
II=II+1
XX=XX+1
环
如果结束
接下来我
I=1
下一个ZZ
如果结束
II=2'重置第一个循环以捕获新的图纸数据
下一个

如果我正确理解了您的问题，您的多张工作表的标题行中有一定数量的列。然后，在相应的列中会有数据行位于下面

您已经查看了每个工作表中的标题，并将这些名称添加到您称为Combine的工作表中。并非所有图纸上的所有列都位于合并图纸上。合并工作表是工作簿中总列名的子集

这些工作表可能包含来自多个测试运行的数据或其他数据。输出可能包含公共列以及一些附加数据。例如，工作表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

选项显式
公共子测试仪（）
“不需要
'尺寸II%，XX%，ZZ%，I%'尺寸尽可能长
将梳子调整为工作表的合并表
Set Comb=此工作簿。工作表（“合并”）
'声明范围对象并将其指定为包含列名
“来自联合收割机。此范围已转换为列表
'下面将比较组合标题名称与
'每一页上的每一列标题。
作为范围的Dim RNG组合标题
'使用函数将组合标题设置到范围内
'EndOfRangeColumn，如下所述
设置rngCombineHeadings=EndOfRangeColumn（组合范围（“A1”））
'声明要在for循环中使用的集合以进行比较
'将列标题与每个源表标题合并
'仅复制匹配的列
Dim ColCombinedHeaders作为集合
'获取列标题的集合（也称为字符串列表）
设置colCombinedHeadings=GetCommonHeadings（rngCombineHeadings）
'声明要用作内部索引的两个范围
'对于下面的循环。
Dim组合目标设定范围
暗淡的颜色范围
'声明一个变量，以使用索引进行looing
'通过合并表格标题
作为变体的变暗vHeading
“宣布tblRng。它将被设置为包含整个数据表
“在每张纸上。第1行包含标题，第2-n行包含
'可以移动的数据。
变暗tblRng As范围
'这是将被操纵和复制的范围
'到联合收割机工作台
暗拷贝As范围
'在工作簿中的工作表中循环
'最佳实践下面每个循环中使用的索引变量为
'在使用变量的位置附近声明变量。
将Sht设置为工作表“此工作簿上的每张工作表”
用于此工作簿中的每个Sht。工作表
'忽略工作表“合并”和“Val”
如果短名称为“Combine”和短名称为“Val”，则
'将数据表设置为tblRng对象。
设置tblRng=endofragerow（短程范围（“A1”））
设置tblRng=内折柱（tblRng）
'对于每张图纸，循环浏览图纸上的每个标题
'合并的表格，并将其与
'当前工作表上数据表的标题
对于ColCombinedHeads中的每个V标题
对于tblRng.列中的每个列
'如果组合上的标题=当前
'然后，复制数据
“到合并的表单。
如果vHeading=colRng.Value2（1,1），则
'调整复制范围的大小以排除标题行
'并将尺寸减少一行，以反映移除
'从范围中删除标题行的
套印机