Question

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

谢谢

Answer 1

请测试下一个代码：

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

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

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

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

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

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

1 个答案: