將多個工作簿中的工作表復制到一個工作簿中並粘貼到右側

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。 合並工作簿/工作表的絕佳工具。 數據庫合並