VBA - copy the first row that has empty cell

[macroos]

Hi,

I want to make a macro to copy the first rows to the last rows that is empty in column A (below: A4 to E6) from workbook called "XXX" to my current workbook called "ZZZ".

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2252[/TD]
[TD]1[/TD]
[TD]7[/TD]
[TD]13[/TD]
[TD]AAA[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2253[/TD]
[TD]2[/TD]
[TD]8[/TD]
[TD]14[/TD]
[TD]BBB[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]2254[/TD]
[TD]3[/TD]
[TD]9[/TD]
[TD]15[/TD]
[TD]CCC[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD][/TD]
[TD]4[/TD]
[TD]10[/TD]
[TD]16[/TD]
[TD]DDD[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD][/TD]
[TD]5[/TD]
[TD]11[/TD]
[TD]17[/TD]
[TD]EEE[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD][/TD]
[TD]6[/TD]
[TD]12[/TD]
[TD]18[/TD]
[TD]FFF[/TD]
[/TR]
</tbody>[/TABLE]

Sub CopyRow()

Dim LastRow As Long, FirstRow As Long
LastRow=Cells(Rows.Count,"B").End(xlUp).Row
FirstRow=Columns("A").Find("",,xlValues, , xlRows, xlPrevious, , , False).Row + 1

Workbooks.Open Filename:="...XXX.xlsx"
Sheets("XXX sheet").Select
Range("A" & FirstRow & ":E" & LastRow).Copy
Window("ZZZ.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
Workbooks("XXX.xlsx").Close savechanges:=FALSE

End Sub

 

[mumps]

Try this macro. change the workbook and sheet names to suit your needs.

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWs As Worksheet
    Set desWs = ThisWorkbook.Sheets("ZZZ sheet")
    Workbooks.Open Filename:="...XXX.xlsx" 'change to appropriate folder path
    Set srcWS = Sheets("XXX sheet")
    Dim LastRow As Long
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim bottomA As Long
    bottomA = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    srcWS.Range("A" & bottomA + 1 & ":E" & LastRow).Copy desWs.Range("A2")
    ActiveWorkbook.Close savechanges:=False
    Application.ScreenUpdating = True
End Sub

 

[macroos]

It works great!

What if I have 10 files, and I basically want to do the same thing?

Rows from XXX are copied onto ZZZ.
Then, next file, the rows would be copied underneath the pasted rows in ZZZ?

 

[mumps]

What is the full path to the folder containing the source files? What is the file extension? Are the source files (10 files) the only files in that folder?

 

[macroos]

All source files are in the same folder with file extension of xlsx.
(File names are 202.01LTD, 204.01LTD, 205.01LTD, 232.01LTD - this format: number.01LTD)
The file with the macro is also in the same folder with extension xlsm.
These are the only files in the folder.

 

[mumps]

This macro assumes that the source sheets in all the source files are named "XXX sheet". You will also have to change the folder path where indicated in the code to match your actual folder path where the files are saved.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, bottomA As Long
    Dim srcWS As Worksheet, desWs As Worksheet
    Set desWs = ThisWorkbook.Sheets("ZZZ sheet")
    Dim srcWB As Workbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB
            Set srcWS = .Sheets("XXX sheet")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            bottomA = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
            srcWS.Range("A" & bottomA + 1 & ":E" & LastRow).Copy desWs.Cells(desWs.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[macroos]

It's not working.
I made sure all source file sheets are using the same name. I changed the folder path to where the files are located.
I tested it out with three files in the folder, but nothing is being copied over.

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, bottomA As Long
    Dim srcWS As Worksheet, desWs As Worksheet
    Set desWs = ThisWorkbook.Sheets("ZZZ sheet")
    Dim srcWB As Workbook
    Const strPath As String = "C:\Test3\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB
            Set srcWS = .Sheets("XXX sheet")
            LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            bottomA = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
            srcWS.Range("A" & bottomA + 1 & ":E" & LastRow).Copy desWs.Cells(desWs.Range("B" & desWs.Rows.Count).End(xlUp).Row + 1, 1)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[macroos]

Nothing is being copied over yet.

 

[mumps]

I tried it on some dummy files and it worked properly. Could you upload a copy of 2 or 3 source files to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbooks contain confidential information, you could replace it with generic data.