将多个工作簿复制到另一个工作簿中的特定行

Question

下面的VBA代码帮助我将指定路径中的所有工作簿导入主工作簿。

代码完美运行

但是，我想稍微调整一下这段代码，以便我可以将代码放在主工作簿的第 5 行

下面的代码帮助我将数据放在下面一行

任何人都可以帮我更改代码，将数据粘贴到当前工作簿的第 5 行。

Sub mergeworkbooks()
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\admin\Desktop\SLO 23032015")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

Range("A65536").End(xlUp).Offset(2, 0).PasteSpecial


Application.CutCopyMode = False
bookList.Close
Next
End Sub

Answer 1

您可以只激活当前最后一行下方 5 行的单元格。在 bookList.Close 之后和 Next 之前添加：

FifthRow = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 5
Cells(FifthRow, 1).Activate

Answer 2

我从两个方面理解这个问题。

如果您只想为第一个工作簿粘贴下面 5 行的数据，请试试这个

我添加了一个计数器来计算循环，在第一个循环中偏移量是6行，其余循环是2行.你也可以尝试一些更简单但不太干净的东西，比如 Before 运行 for loop For Each everyObj In filesObj 你可以在 Range("A5") 中放置一些文本，这样当它寻找最后一行时会找到第 6 行而不是第 5 行。但这是一个偏好问题。示例 Range("A5").Value = "SomeText"

Sub mergeworkbooks()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim iCount as Long

Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")


Set dirObj = mergeObj.Getfolder("C:\Users\admin\Desktop\SLO 23032015")
Set filesObj = dirObj.Files

iCount = 1
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
If iCount = 1 then 
    Range("A" & Rows.Count).End(xlUp).Offset(6, 0).PasteSpecial
    iCount = 0
Else
    Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial
end if

Application.CutCopyMode = False
bookList.Close
Next
End Sub

否则，如果您想要 5 行间距用于在所有工作簿之间粘贴数据，请使用以下代码我只是将下一行中的偏移量从 2 修改为 6 ... 范围("A65536").结束(xlUp).偏移(6, 0).PasteSpecial

Sub mergeworkbooks()
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\admin\Desktop\SLO 23032015")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

Range("A" & Rows.Count).End(xlUp).Offset(6, 0).PasteSpecial


Application.CutCopyMode = False
bookList.Close
Next
End Sub

将多个工作簿复制到另一个工作簿中的特定行

Copy multiple workbooks to a specific row in another workbook

excel

vba

excel-2007

excel-formula

excel-2010