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

 

[macroos]

https://www.dropbox.com/sh/8hisrzt3jqtgva3/AADVokzAD4XGzM4vuwEH9L9za?dl=0

 

[mumps]

I made one minor change in the code but the reason it wasn't working is because a backslash was missing at the end of the folder path (highlighted in red). Try this version;

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, bottomA As Long
    Dim srcWS As Worksheet, desWs As Worksheet
    Set desWs = ThisWorkbook.Sheets("Final")
    Dim srcWB As Workbook
    Const strPath As String = "C:\Users\ayeh\Desktop\New folder[COLOR="#FF0000"]\[/COLOR]" '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("Final Schedule")
            LastRow = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).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]

It works! Thank you for all your help!!!

 

[mumps]

You are very welcome.