Copy range downwards till certain cell

Hi Jonathan78,

There may be more elegant ways to do this, but this one should do the job.

Try this:

Sub main()

    Dim rngA As Range, rngB As Range
    Dim lRow As Long, lRowEnd As Long

    lRowEnd = 100        'change end row here

    With Sheets(1)

        Set rngA = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
        Set rngB = .Range("D3", .Range("D" & Rows.Count).End(xlUp))

        lRow = rngA.Cells(1).Row
        Do
            lRow = lRow + rngA.Rows.Count
            .Cells(lRow, rngA.Column).Resize(rngA.Rows.Count, 1) = rngA.Value
        Loop While lRow < lRowEnd

        lRow = rngB.Cells(1).Row
        Do
            lRow = lRow + rngB.Rows.Count
            .Cells(lRow, rngB.Column).Resize(rngB.Rows.Count, 1) = rngB.Value
        Loop While lRow <= lRowEnd

        Application.Intersect(.Columns(rngA.Column), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents
        Application.Intersect(.Columns(rngB.Column), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents

    End With
    
    Set rngA = Nothing
    Set rngB = Nothing

End Sub