Copy range downwards till certain cell

In that case, 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
            .Cells(lRow, "H").Resize(rngA.Rows.Count, 1) = rngA.Value
            lRow = lRow + rngA.Rows.Count
        Loop While lRow <= lRowEnd

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

        Application.Intersect(.Columns("H"), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents
        Application.Intersect(.Columns("J"), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents

    End With
    
    Set rngA = Nothing
    Set rngB = Nothing

End Sub