How to repeat macro until end

[aeop]

I have a macro which uses the first row of data and copy and pastes it to a new sheet in a certain order. How do I get that process to continue for every row until the end of the data?

[jaslake]

Hi aeop

The Code you reference is not in the Workbook you attached. It's a bit difficult to help amend Code we can't see.

[mike7952]

Something like this

Option Explicit

Sub abc()
 Const shStart As String = "start"
 Const shFinish As String = "finish"
 Dim aArr, b, i As Long, ii As Long, n As Long
 
 
 With Worksheets(shStart)
    aArr = .Range("a1").CurrentRegion.Value
 End With
 
 ReDim b(1 To UBound(aArr) * 8, 1 To 5)
 
 For i = 2 To UBound(aArr)
    n = n + 1
    b(n, 1) = aArr(1, 1)
    b(n, 2) = aArr(1, 2)
    b(n, 3) = aArr(1, 4)
    b(n, 4) = "Phase"
    b(n, 5) = "Amount"
    n = n + 1
    b(n, 1) = aArr(i, 1)
    b(n, 2) = aArr(i, 2)
    b(n, 3) = aArr(i, 4)
    b(n, 4) = aArr(1, 5)
    b(n, 5) = aArr(i, 5)
    n = n + 1
    b(n, 1) = aArr(i, 1)
    b(n, 2) = aArr(i, 2)
    b(n, 3) = aArr(i, 4)
    b(n, 4) = aArr(1, 7)
    b(n, 5) = aArr(i, 7)
    
    For ii = 9 To UBound(aArr, 2)
        n = n + 1
        b(n, 1) = aArr(i, 1)
        b(n, 2) = aArr(i, 2)
        b(n, 3) = aArr(i, 4)
        b(n, 4) = aArr(1, ii)
        b(n, 5) = aArr(i, ii)
    Next
    n = n + 2
 Next
 With Worksheets(shFinish)
    .Cells.Clear
    .Range("a1").Resize(n, 5) = b
    .Columns.AutoFit
 End With
End Sub

[JOHN H. DAVIS]

Maybe:

Sub aeop()
Dim lr As Long
Dim y As Integer
Dim x As Integer
Dim ws As Worksheet
Dim rcell As Range

Application.ScreenUpdating = False

Set ws = ActiveSheet

lr = ws.Cells(Rows.Count, 1).End(xlUp).Row

For Each rcell In ws.Range("A2:A" & lr)

    x = 6
    y = 1
    
    ws.Range("A1").Copy Sheets("Finish").Range("A" & Rows.Count).End(3)(4)
    ws.Range("B1").Copy Sheets("Finish").Range("B" & Rows.Count).End(3)(4)
    ws.Range("D1").Copy Sheets("Finish").Range("C" & Rows.Count).End(3)(4)
    Sheets("Finish").Range("D" & Rows.Count).End(3)(4).Value = "Phase"
    Sheets("Finish").Range("E" & Rows.Count).End(3)(4).Value = "Amount"
    
    Do Until x = 0
    
        ws.Range(rcell, rcell.Offset(, 2)).Copy Sheets("Finish").Range("A" & Rows.Count).End(3)(2)
        Sheets("Finish").Range("D" & Rows.Count).End(3)(2) = "Phase" & y
        Sheets("Finish").Range("C" & Rows.Count).End(3)(2) = "New"
            Select Case y
            
                Case Is = 1
            
                    Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 4).Value
        
                Case Is = 2
                
                    Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 6).Value
                
                Case Is = 3
                
                     Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 8).Value

                Case Is = 4
                
                    Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 9).Value

                Case Is = 5
                
                    Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 10).Value
                
                Case Is = 6
                
                    Sheets("Finish").Range("E" & Rows.Count).End(3)(2) = rcell.Offset(, 11).Value

        End Select

        x = x - 1
        y = y + 1
    Loop
    

Next rcell

Sheets("Finish").Range("A1:A3").EntireRow.Delete xlUp

Application.ScreenUpdating = True


End Sub