Copy cells in loop

[Insterburg]

I'd like to copy cells row after row from row=2 to last used row and paste them in special order as in attached file
copy.xlsx

Thank you

[Yongle]

One way of doing it - assumes data begins in row 2 and that there is a value in every cell in column C up to the last row.

Sub Duplicate_by_copy()
    
    Dim i As Integer, LastRow As Long
    LastRow = ActiveSheet.Range("C2").End(xlDown).Row
    With ActiveSheet
        For i = LastRow To 2 Step -1
            .Rows(i).EntireRow.Copy
            .Cells(i + 1, 1).EntireRow.Insert
            .Cells(i, 1).PasteSpecial xlPasteAll
        Next i
    End With
End Sub

[Insterburg]

Than you, but cells should be pasted in order shown in attached file, not always row after row. If cells(i,"A").Value <> ''" and Cells(i, "C").Value <> "" then
we duplicate cells in row i , but when Cells(i,"A").Value <> "" and cells(i+x,"A").Value ="" we duplicate cells in rows from i to next used cell in "A" col
x - empty rows between used cells in "A" col

[Yongle]

Try this.
I have included several message boxes so that you can see what the code does as it does it.
Assumptions
- data starts in line 2
- column C contains values from line 2 to end of range
- blank cells in column A are empty (beware suppressed zeros etc!)

Sub Duplicate_by_copy()
    
    Dim i As Integer, LastRow As Long, f As Integer
    LastRow = ActiveSheet.Range("C2").End(xlDown).Row
        
        With ActiveSheet
            For i = LastRow To 2 Step -1
                If .Cells(i, 1).Value <> "" Then
MsgBox Cells(i, 1).Address(0, 0) & " is NOT BLANK. Value is " & .Cells(i, 1).Value & vbNewLine & vbNewLine & "hence ROW ONLY" & vbNewLine & vbNewLine & "copy from row " & .Cells(i, 1).Row
                    .Cells(i + 1, 1).EntireRow.Insert
                    .Rows(i).EntireRow.Copy
                    .Cells(i + 1, 1).PasteSpecial xlPasteAll
MsgBox "paste to row" & .Cells(i + 1, 1).Row
                Else
MsgBox .Cells(i, 1).Address(0, 0) & " is BLANK " & .Cells(i, 1).Value & vbNewLine & vbNewLine & "hence copy RANGE"
                    f = .Cells(i, 1).End(xlUp).Row
MsgBox "beginning of range set by " & .Cells(f, 1).Address(0, 0) & vbNewLine & "end of range set by " & .Cells(i, 3).Address(0, 0)
                    .Rows(i + 1 & ":" & i + 1 + i - f).EntireRow.Insert
                    .Rows(f & ":" & i).EntireRow.Copy
MsgBox "copy from rows " & f & " : " & i & vbNewLine & "to rows " & i + 1 & " : " & i + 1 + i - f
                    .Cells(i + 1, 1).PasteSpecial xlPasteAll
                    i = f
                End If
            Next i
        End With


End Sub

[Insterburg]

Thank you, maybe my explanation was unclear. The data in sheet is organized in some kind of sets:

1. A2:C2 - data in 1 row
2. A3:C4 - data in 2 rows with blank cells
3. A5:C7 - data in 3 rows with blank cells
4. A8:C8 - data in 1 row
etc.


and these sets should be copied as a ranges rather than rows, each set as a whole and placed duplicated somewhere in sheet- for instance:

1. A12: C12
A13: C13 duplicated
2. A14: C15
A16: C17 duplicated
3. A18: C20
A21: C23 duplicated
4. A24: C24
A25: C25 duplicated

[Yongle]

@Insterburg
I think your cells in column A are not empty
Go into all the blank cells in column A and hit delete and run the code again - the code will work I am sure

Let me know

[Yongle]

@Insterburg
Did this solve your problem?

[Insterburg]

Yes you are right, these cells were not empty. Now it works fine. Thank you.