将单元格复制并粘贴到VBA循环下面的行中

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!

Answer 1

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'.

Answer 2

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

Answer 3

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