时间戳

首页 > 解决方案 > 按名称查找列标题，然后从多个工作簿中选择标题下方的所有数据，然后将数据粘贴到 Excel VBA 的主文件中的另一个下方

excel - 按名称查找列标题，然后从多个工作簿中选择标题下方的所有数据，然后将数据粘贴到 Excel VBA 的主文件中的另一个下方

问题描述

我在一个特定文件夹中有 5 个不同的工作簿，每个工作簿中只包含一张工作表。每个工作簿都有相同的格式，第 12 行有大约 145 个标题。这个标题下面有一些数据，请注意每个工作簿中的数据不同，也有缺失数据，所以不确定最后一行数据。在主文件中，我在第 3 行提到了 30 个需要的标题。我需要一个 VBA 宏，它应该从主文件中查找标题并从第一个文件中复制数据并将其粘贴到主文件中。从第一个文件复制数据后，它应该从第二个、第三个、第四个和第五个文件复制数据，并将一个粘贴到另一个主文件中。

谢谢

标签： excelvba

解决方案

请测试下一个代码：

Sub CopyInMaster()
   Dim wb As Workbook, mWb As Workbook, mWbPath As String, shMWb As Worksheet, ws As Worksheet
   Dim folderPath As String, fileName As String, arrHead, lastERM As Long, lastrWS As Long, arrCopy, i As Long, j As Long
   
   folderPath = ThisWorkbook.path & "\TestImport\"  'use here the folder path where the workbooks to import data exist
                                                                       'please, take care of the ending"\"
   mWbPath = folderPath & "Master.xlsx"                 'use here your Master workbook full name
   
   'check if the master workbook is open. If not, open it
   For Each wb In Workbooks
        If wb.fullName = mWbPath Then Set mWb = wb: Exit For
   Next
   If mWb Is Nothing Then
        Set mWb = Workbooks.Open(mWbPath)
   End If
   
   Set shMWb = mWb.Sheets(1) 'if the sheet to be updated in Master wb is not the first one, please adapt the code using its name
   'put master headers in an array:
   arrHead = shMWb.Range("A1", shMWb.cells(1, shMWb.Columns.count).End(xlToLeft)).value

   'iterate between all workbooks to be used in the necessary folder:
   fileName = Dir(folderPath & "*.xls*")
   Do While fileName <> ""
        If Not fileName = mWb.Name Then 'if the master workbook is not in the same folder, this lines can be eliminated (If - End If)
            Set wb = Workbooks.Open(folderPath & fileName)
            Set ws = wb.Sheets(1)
            'copy each mathing column data:
            For i = 1 To UBound(arrHead, 2)
                For j = 1 To ws.cells(12, ws.Columns.count).End(xlToLeft).Column
                    If arrHead(1, i) = ws.cells(12, j).value Then
                        lastrWS = ws.cells(ws.rows.count, j).End(xlUp).row            'last row
                        lastERM = shMWb.cells(shMWb.rows.count, i).End(xlUp).row + 1  'first empty row
                        arrCopy = ws.Range(ws.cells(13, j), ws.cells(lastrWS, j)).value      'put the range to be copied in an array (to be faster)
                        shMWb.cells(lastERM, i).Resize(UBound(arrCopy), UBound(arrCopy, 2)).value = arrCopy 'drop the array content
                    End If
                Next
            Next i
            wb.Close False  'close the workbook without saving it
        End If
        fileName = Dir()
   Loop
End Sub

请注意正确调整必要的路径和“主”工作簿全名！

很高兴知道，除了上面的代码，我们这里不提供免费的编码服务。我们（通常）只帮助人们理解他们的编码问题并学习。因此，您应该向我们展示您自己尝试过的内容，并更好地解释要做什么。请理解我做了一个例外！

还很高兴知道，在提出问题时，经常检查并回答澄清问题（如果有）至少是礼貌的。

测试后，我想收到一些反馈。我问了澄清，我只是假设这是你喜欢做的。如果没有，请根据代码返回的内容准确描述您需要什么。

推荐阅读