将多个工作簿中的工作表复制到一个工作簿中并粘贴到右侧

Question

我现在真的很感激一些帮助。

我试图从多个工作簿的Sheet1中获取一系列单元格F37:F53并将其粘贴到新工作簿的Sheet1中。 我遇到的一个问题是所有数据都粘贴在一列中。 我真正想要的是将每组数据粘贴到右侧的列中。 因此，换句话说，工作簿 1 的F37:F53应粘贴到最终工作簿的A1中。 然后将工作簿 2 的F37:F53粘贴到最终工作簿的B1中。 以此类推，限制为 365 列

我真的很感激一些帮助，因为我对 VBA 还很陌生

先感谢您！

这是我到目前为止所拥有的：

Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

Set dirObj = mergeObj.Getfolder("C:\Users\a0086850\Documents\421\2017")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("F37:F53" & Range("F65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("2017").Activate

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub

Answer 1

假设 FSO 位是正确的，试试这个

Sub simpleXlsMerger()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim c As Long

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")
Set dirObj = mergeObj.Getfolder("C:\Users\a0086850\Documents\421\2017")
Set filesObj = dirObj.Files

For Each everyObj In filesObj
    Set bookList = Workbooks.Open(everyObj)
    c = c + 1
    bookList.Sheets(1).Range("F37:F53").Copy ThisWorkbook.Worksheets("2017").Cells(1, c)
    bookList.Close
Next

End Sub

Answer 2

如果这只是你需要快速的东西，我建议使用 RDBMerge。 合并工作簿/工作表的绝佳工具。 数据库合并