Copy and Paste from multiple workbooks into a single workbook into the next blank row

Question

Any help would be greatly appreciated. What I'm trying to accomplish is to take the same range from multiple workbooks and paste into a single separate workbook. The issue that I am running into is that I would like to have the data paste down into the next available row. My current code does everything correctly except the paste vba (the data is currently overlapping)

Also the ranges I am copying from have blank rows so a way to have the paste code remove blank rows would be amazing.

Any help in this would fantastic!

Thank you in advance

Sub MergeYear()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As 
Object
Dim r As Long
Dim path As String

path = ThisWorkbook.Sheets(1).Range("B9")

Set mergeObj = CreateObject("Scripting.FileSystemObject")
Set dirObj = mergeObj.Getfolder(path)
Set filesObj = dirObj.Files

For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
r = r + 1
bookList.Sheets(5).Range("A2:Q366").Copy ThisWorkbook.Sheets(5).Cells(r + 1, 
1)
bookList.Close
Next everyObj

End Sub

Possible duplicate of [Error in finding last used cell in VBA](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-vba) — Victor K, Oct 23 '17 at 19:35

Cyril · Answer 1 · 2017-10-24T13:30:28.450

3

You need to define the last row, then paste into last row + 1.

With ThisWorkbook.Sheets(5) 
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    bookList.Sheets(5).Range("A2:Q366").Copy .Cells(r + 1, 1)
End With

Edit

Adding in the second part of the question. Assuming all blank rows are copied to the master destination sheet, so we just need to remove blanks there... note that this might be slow, depending on how many lines you've got:

Dim j as Long, LR as Long
With ThisWorkbook.Sheets(5)
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'Assumes col A is contiguous
    For j = LR to 1 Step -1 'VERY IMPORTANT WHEN DELETING
        If .Cells(j, "A").Value = "" Then 'Assumes A must contain values
            .Rows(i).Delete
        End If
    Next j
End With

edited Oct 24 '17 at 13:30

answered Oct 23 '17 at 19:37

Cyril

6,448
1
18
31

Used your existing r As Long – Cyril Oct 23 '17 at 19:37
This works great! help on how I could remove the blank rows while pasting? Each of the ranges I'm coping have blank rows. – Dan C Oct 23 '17 at 19:45
Are there formulas present or just hard coded values? May wish to use bookList.Sheets(5).Range("A2:Q366").SpecialCells(xlCellTypeConstants) – QHarr Oct 23 '17 at 19:55
2

Assuming the criteria column to find blank rows can be A and contains constants (i.e. not formulas), use `Application.Intersect(bookList.Sheets(5).Range("A2:A366").SpecialCells(XlCellType.xlCellTypeConstants).EntireRow,bookList.Sheets(5).Range("A2:Q366")).Copy ...`. The principle here is that SpecialCells will quickly find constants within the criteria column, which are expanded to entire rows and then intersected with the range of interest; the result is copied. Note that this will fail if there aren't any constants in column A, with message `No cells were found`. Use error handling. – Excelosaurus Oct 23 '17 at 19:57
@DanC Excelosaurus/QHarr have a good solution to your other problem. I will post another solution as part of my answer, in case you just have blanks in the original documents (we will loop a second time through all of the pasted data to remove blank rows). – Cyril Oct 24 '17 at 13:27

Copy and Paste from multiple workbooks into a single workbook into the next blank row

1 Answers1