Copy range downwards till certain cell

Thanks for helping Berlan,

Is it possible to get the result in column H instead of underneath the existing range?

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

That works fine Berlan.

is it possible to start from a selected cell?

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

    lRowEnd = 100        'change end row here

    With Worksheets("RS")
        Set rngA = .Range("AF7", .Range("AF" & Rows.Count).End(xlUp)).Offset(, 1)

        lRow = rngA.Cells(1).Row
        Do
            Worksheets("A").Cells(lRow, "O").Resize(rngA.Rows.Count, 1) = rngA.Value
            lRow = lRow + rngA.Rows.Count
        Loop While lRow <= lRowEnd
        
        Application.Intersect(.Columns("O"), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents
    End With

    Set rngA = Nothing

In this example, you can select both your input and output range. Try this:

Sub main()

    Dim rngInput As Range, rngOutput As Range
    Dim lRow As Long, lRowEnd As Long

CalculateInput:
    Set rngInput = Application.InputBox("Select input cells", Type:=8)
    If rngInput.Columns.Count > 1 Then MsgBox "Only select cells from one column": GoTo CalculateInput
    
CalculateOutput:
    Set rngOutput = Application.InputBox("Select output cells", Type:=8)
    If rngOutput.Columns.Count > 1 Then MsgBox "Only select cells from one column": GoTo CalculateOutput
    
    With ThisWorkbook.Sheets(rngOutput.Parent.Name)
        lRow = rngOutput.Cells(1).Row
        lRowEnd = rngOutput.Rows.Count + lRow - 1
        Do
            .Cells(lRow, rngOutput.Cells(1).Column).Resize(rngInput.Rows.Count, 1) = rngInput.Value
            lRow = lRow + rngInput.Rows.Count
        Loop While lRow <= lRowEnd
        Application.Intersect(.Columns(rngOutput.Cells(1).Column), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents
        .Activate
    End With
    
    Set rngInput = Nothing: Set rngOutput = Nothing
    
End Sub

Happy holidays!

This is just awesome and will definitely use it in the future!
But for now I'd like the user only to select the starting cell from where on the range will be copied down till the 100th row.

Applying it to your latest code, which I am then unable to test properly without seeing more of the workbook, so try if this would work?

You will select the starting cell from where the range will be copied down to to the 100th row.

Sub main()

    Dim rngA As Range, rngB As Range
    Dim lRow As Long, lRowEnd As Long
    
CalculateOutput:
    Set rngB = Application.InputBox("Select output cells", Type:=8)
    If rngB.Cells.Count > 1 Then MsgBox "Please select a single cell": GoTo CalculateOutput
    
    With Sheets("RS")
        Set rngA = .Range("AF7", .Range("AF" & Rows.Count).End(xlUp)).Offset(, 1)
    End With

    With ThisWorkbook.Sheets(rngB.Parent.Name)
        lRow = rngB.Cells(1).Row
        lRowEnd = 100   'copied down to the 100th row
        Do
            .Cells(lRow, rngB.Cells(1).Column).Resize(rngA.Rows.Count, 1) = rngA.Value
            lRow = lRow + rngA.Rows.Count
        Loop While lRow <= lRowEnd
        Application.Intersect(.Columns(rngB.Cells(1).Column), .Rows((lRowEnd + 1) & ":" & Rows.Count)).ClearContents
        .Activate
    End With
    
    Set rngA = Nothing: Set rngB = Nothing
    
End Sub

That's it!
Thank you so much for helping me out with this.
Happy Holidays!