Copy and Paste Cell into row below VBA Loop

Question

I am trying to create VBA code that copies and pastes data from Column B into the row directly beneath in Column A. I do not have great experience with VBA and so I am struggling to create such a code.

I would like to create a code that loops for an entire set of data in Columns A and B as shown in the attached picture.

So for example, B3 would get pasted into A4. B5 would get pasted into A6. And all the way down until the list was completed.

Thank you for any help!

you could write in C3 `=A3` and in C4 `=B3`. Then simply copy down and you got the list you desitre (simply copy/paste(values only) to the range at column A at the end) — Dirk Reichel, Jan 28 '16 at 23:04
Or simply: `Sub test(): Dim i As Long: i = 3: While Len(Cells(i, 1)): Cells(i + 1, 1) = Cells(i, 2): i = i + 2: Wend: End Sub` — Dirk Reichel, Jan 28 '16 at 23:20

score 1 · Answer 1 · answered Jan 28 '16 at 23:07

Here is a simple example that will do what you ask.

For i = 2 To 10
If Range("A" & i) > "" And Range("A" & i + 1) = "" Then
    Range("B" & i).Cut
    Range("A" & i + 1).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Else
    End If
Next

Depending on what your data looks like, you will probably want to setup something more dynamic for the value of 'i'.

score 1 · Answer 2 · edited May 23 '17 at 12:31

Use LastRowIndex from https://stackoverflow.com/a/71296/42346 to find the final row then iterate over the rows in column 2 placing the value in column 1 one row below the current row.

Sub iterate()
    Dim r As Long
    Dim c As Long
    Dim endrow As Long

    c = 2
    endrow = LastRowIndex(ActiveSheet, c)
    For r = 2 To endrow Step 1
        If ActiveSheet.Cells(r, c).Value <> "" Then
             ActiveSheet.Cells(r + 1, c - 1).Value = ActiveSheet.Cells(r, c).Value
        End If
    Next r
End Sub

Function LastRowIndex(ByVal w As Worksheet, ByVal col As Variant) As Long
  Dim r As Range

  Set r = Application.Intersect(w.UsedRange, w.Columns(col))
  If Not r Is Nothing Then
    Set r = r.Cells(r.Cells.Count)

    If IsEmpty(r.Value) Then
      LastRowIndex = r.End(xlUp).Row
    Else
      LastRowIndex = r.Row
    End If
  End If
End Function

score 1 · Accepted Answer · answered Jan 28 '16 at 23:35

1

The below code works quite good for your criteria.

rowNum = 3
Do While Trim(Range("A" & rowNum).Value) <> ""
   Range("A" & (rowNum + 1)).Value = Range("B" & rowNum).Value
   rowNum = rowNum + 2
Loop

answered Jan 28 '16 at 23:35

Animesh

208
1
5
13

Works great. Thank you! – DV7 Jan 28 '16 at 23:52

Copy and Paste Cell into row below VBA Loop

3 Answers3