Home > Software design >  copy loop based on cell value with offset
copy loop based on cell value with offset

Time:07-30

I'm fairly new to VBA and coding in general, but I'm trying to create a do until loop that sees the value in a specific cell and then copies and pastes down the rows of a different sheet the same number of times as the specified cell value with an offset of 24 rows. The code is looping, but I can't get it to offset, but with my limited knowledge I'm unsure where I'm going wrong or if this is even the correct way to go about it.

Sub Loop_one()

    Dim ws As Worksheet, wsInput As Worksheet, wsOutput As Worksheet
    Dim i As Byte, j As Long, OffsetBy As Long
    Dim cell As Range, lngDataRows As Long
    i = Sheet2.Range("D23").Value
    j = 1
    Set ws = Sheets("CFS")
    Set wsInput = Sheets("Table")
    Set wsOutput = Sheets("RD")
    
    wsInput.Visible = xlSheetVisible
    ws.Activate

    If Range("D20") = ("1") And Range("D22") = ("1") Then
        wsOutput.Select
        wsInput.Range("B2:K28").copy wsOutput.Range("B14")
        Do Until j = i
            OffsetBy = 1
            j = j   1
            wsOutput.Range("B14").Offset(lngDataRows   OffsetBy, 0).Select
            OffsetBy = OffsetBy   23
            wsInput.Range("B2:K28").copy
            wsOutput.Range("B14").PasteSpecial Paste:=xlPasteColumnWidths, _
                                                        Operation:=xlNone, _
                                                        SkipBlanks:=False, _
                                                        Transpose:=False
    
        Loop
        wsOutput.Select
    End If

End Sub

CodePudding user response:

It's easier to use a Range variable as the paste destination, so you can avoid all those offset calculations...

Like this should work:

Sub Loop_one()

    Dim ws As Worksheet, wsInput As Worksheet, wsOutput As Worksheet
    Dim reps As Long, j As Long, OffsetBy As Long
    Dim pastePos As Range, lngDataRows As Long
    
    Set ws = Sheets("CFS")
    Set wsInput = Sheets("Table")
    Set wsOutput = Sheets("RD")
    
    reps = Sheet2.Range("D23").Value 'is this one of the 3 sheets above?
    wsInput.Visible = xlSheetVisible
    
    If ws.Range("D20") = 1 And ws.Range("D22") = 1 Then
        Set pastePos = wsOutput.Range("B14") ' first paste destination
        For j = 1 To reps
            wsInput.Range("B2:K28").Copy pastePos
            Set pastePos = pastePos.Offset(24) '  move paste destination 24 rows down
        Next j
    End If
    
End Sub
  • Related