Search code examples
excelvbaloopscopy-pasteoffset

Offset the Copy Row as part of a Loop


I have written the below code but i would like the macro to repeat this process, copying the next row down in the SS21 Master Sheet until that row is blank (the end of the table).

Something like this?

enter image description here

   Sub Run_Buysheet()
Sheets("SS21 Master Sheet").Range("A1:AH1, AJ1:AK1, AQ1").Copy Destination:=Sheets("BUYSHEET").Range("A1")

Sheets("SS21 Master Sheet").Range("A2:AH2, AJ2:AK2, AQ2").Copy Destination:=Sheets("BUYSHEET").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

Dim r As Range, i As Long, ar
Set r = Worksheets("BUYSHEET").Range("AK999999").End(xlUp) 'Range needs to be column with size list
Do While r.Row > 1
    ar = Split(r.Value, "|") '| is the character that separates each size
    If UBound(ar) >= 0 Then r.Value = ar(0)
    For i = UBound(ar) To 1 Step -1
        r.EntireRow.Copy
        r.Offset(1).EntireRow.Insert
        r.Offset(1).Value = ar(i)
    Next
    Set r = r.Offset(-1)
Loop
 End Sub

SS21 Master Sheet

enter image description here

BUYSHEET

enter image description here


Solution

  • This scans the MASTER sheet and adds rows to the bottom of the BUYSHEET

    Sub runBuySheet2()
    
      Const COL_SIZE As String = "AQ"
    
      Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
      Set wb = ThisWorkbook
      Dim iLastRow As Long, iTarget As Long, iRow As Long
      Dim rngSource As Range, ar As Variant, i As Integer
    
      Set wsSource = wb.Sheets("SS21 Master Sheet")
      Set wsTarget = wb.Sheets("BUYSHEET")
    
      iLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
      iTarget = wsTarget.Range("AK" & Rows.Count).End(xlUp).Row
    
      With wsSource
      For iRow = 1 To iLastRow
         Set rngSource = Intersect(.Rows(iRow).EntireRow, .Range("A:AH, AJ:AK, AQ:AQ"))
         If iRow = 1 Then
            rngSource.Copy wsTarget.Range("A1")
            iTarget = iTarget + 1
         Else
           ar = Split(.Range(COL_SIZE & iRow), "|")
           For i = 0 To UBound(ar)
               rngSource.Copy wsTarget.Cells(iTarget, 1)
               wsTarget.Range("AK" & iTarget).Value = ar(i)
               iTarget = iTarget + 1
           Next
         End If
      Next
      MsgBox "Completed"
      End With
    
    End Sub