VBA：將多個工作簿（具有多個工作表）中的特定單元格復制到單個工作簿

Question

希望你一切安好。 我是 VBA 新手。 我們正在努力做到以下幾點：

1. 我們有多個工作簿，有 7 個工作表。 Sheet1 到 Sheet 8。（雖然不需要 Sheet 3 到 Sheet 8）。

所有工作簿中所有 Sheet1 的格式都相同，

所有工作簿等中所有 Sheet2 的格式都相同。

2. 我們想編寫一個 VBA 代碼來執行以下操作：在單獨的 Output.xlsm 表中：

一種。 復制WorkBook1的Sheet 1中B2的值，粘貼到Output.xlsm的A1中

灣復制WorkBook1的Sheet 2中的區域A3:F8，粘貼到Outputl.xlsm的B2中

C。 然后循環遍歷所有其他工作簿並執行與上述相同的操作，並將數據粘貼到另一個之下。 這是我們嘗試過的代碼：它並沒有真正起作用：

Sub ExportData_MultiFiles()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = ThisWorkbook

Dim ws As Worksheet

Dim L As Long, x As Long
sPath = "E:\downloads\Reports\" '<< files in folder , change path as needed
sFile = Dir(sPath & "*.xls*")
Application.ScreenUpdating = False
Set ws = Sheets.Add(before:=Sheets(1))

Do While sFile <> ""
Set wb2 = Workbooks.Open(sPath & sFile)
For x = 1 To wb2.Sheets.Count

wb1.Sheets(x).Cells(1, 1).Value = wb2.Worksheets("Sheet1").Cells(2, 2).Value
wb1.Sheets(x).Cells(1, 2).Value = wb2.Worksheets("Sheet2").Range("A3:F8").Value


Next
wb2.Close False
sFile = Dir()
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub

已共享 3 個工作簿文件作為示例。

1. 工作簿1.xlsx
2. 工作簿2.xlsx
3. 輸出.xlsx

https://drive.google.com/drive/folders/1I8nso3t6AfXrbV87cXcrKfJxQM3vaXMT?usp=sharing

我們已經嘗試研究 StackOverFlow 中的許多帖子，請您指導我們如何完成。

先感謝您。

Answer 1

由於您沒有回答我的澄清問題，請嘗試下一個代碼。 它將在同一個新添加的工作表中復制所有提到的范圍。 從新打開的工作簿中，范圍將粘貼在第一個空行中，根據 B:B 列單元格計算：

Sub ExportData_MultiFiles()
 Dim wb1 As Workbook, wb2 As Workbook, Spath As String, sFile As String
 Dim lastRow As Long, ws As Worksheet

 Set wb1 = ThisWorkbook

 Spath = "E:\downloads\Reports\" '<< files in folder , change path as needed
 sFile = Dir(Spath & "*.xls*")
 Application.ScreenUpdating = False
 Set ws = wb1.sheets.Add(Before:=sheets(1))

 Do While sFile <> ""
    Set wb2 = Workbooks.Open(Spath & sFile)
    lastRow = ws.Range("B" & rows.count).End(xlUp).row + 1
    ws.Range("A" & lastRow).Resize(6, 1).value = wb2.Worksheets("Sheet1").Range("B2").value
    ws.Range("B" & lastRow).Resize(6, 6).value = wb2.Worksheets("Sheet2").Range("A3:F8").value

    wb2.Close False
    sFile = Dir()
 Loop
 ActiveWorkbook.Save
 Application.ScreenUpdating = True
End Sub