VBA Macro to copy and paste range into adjacent columns until condition is met

[A Rossi]

Hi everyone
I need a Macro to repeat a copy and paste process until a condition is met.
I came up with the following code that works it is just clunky. Need help to make it more efficient.
Also i want the program to end when the condition is met not a predetermine number of column ranges.
Thanks
A Rossi

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; white-space: inherit;">Sub Copy()

Dim cell As Range
ForEach cell In Range("D11")
If cell.Value <1000Then

Range("D7:D46").Copy
Range("E7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("E11")
If cell.Value <1000Then

Range("E7:E46").Copy
Range("F7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("F11")
If cell.Value <1000Then

Range("F7:F46").Copy
Range("G7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("G11")
If cell.Value <1000Then

Range("G7:G46").Copy
Range("H7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("H11")
If cell.Value <1000Then

Range("H7:H46").Copy
Range("I7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("I11")
If cell.Value <1000Then

Range("I7:I46").Copy
Range("J7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("J11")
If cell.Value <1000Then

Range("J7:J46").Copy
Range("K7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

ForEach cell In Range("K11")
If cell.Value <1000Then

Range("K7:K46").Copy
Range("L7").Select
ActiveSheet.PasteSpecial

EndIf
Next cell

End Sub</code>

 

[=ODIN=]

maybe this?

Sub da_copy()
    Dim firstColumn As Integer, lastColumn As Integer, firstRow As Long, lastRow As Long, checkRow As Long
    firstColumn = 4
    lastColumn = 26
    firstRow = 7
    lastRow = 46
    checkRow = 11
    


               
        For q = firstColumn To lastColumn
            If Cells(checkRow, q).Value < 1000 Then
                Range(Cells(firstRow, q + 1), Cells(lastRow, q + 1)).Value = Range(Cells(firstRow, q), Cells(lastRow, q)).Value
                Exit Sub
            End If
        Next q


    
End Sub