PDA

View Full Version : Copy cells in loop



Insterburg
03-28-2015, 09:05 AM
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
13091

Thank you

Yongle
03-28-2015, 09:56 AM
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
03-28-2015, 11:53 AM
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
03-29-2015, 12:40 AM
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
03-29-2015, 02:22 AM
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
03-29-2015, 06:26 AM
@Insterburg (http://www.vbaexpress.com/forum/member.php?56246-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
03-30-2015, 04:50 AM
@Insterburg (http://www.vbaexpress.com/forum/member.php?56246-Insterburg)
Did this solve your problem?

Insterburg
03-31-2015, 09:54 AM
Yes you are right, these cells were not empty. Now it works fine. Thank you.