根据相邻列中的值复制/粘贴数据

Question

嗨，我是VBA的新手，碰壁了。 尝试将代码片段与我所了解的很少的内容拼凑在一起，但我觉得自己不胜其烦。 我非常感谢构建代码块以实现以下目标的任何帮助：

在以下工作表中

1. 我试图遍历A列并标识任何空白单元格。

2. 如果单元格为空白，我想复制与A列中空白单元格右侧相邻的4个单元格范围内的值。例如：如果循环将A2标识为空白单元格，则循环将复制range（ “ B2：E2”）

3. 从这里，我想将复制范围以下的值仅粘贴到A列中非空白的行。例如：循环将A列中的非空白行标识为（“ A3：A9”），并将数据粘贴至下面复制的范围到范围（“ B3：E9”）

4. 循环将在列中的下一个空白行处停止并重新启动该过程

这是数据的屏幕截图：

这是我到目前为止的内容，对不起，谢谢。

Sub select_blank()

For Each Cell In Range(ActiveCell, ActiveCell.End(xlDown))
    If IsEmpty(ActiveCell.Value) = True Then
        ActiveCell.Offset(, 1).Resize(, 5).copy
    End If
Next
End Sub

Answer 1

您的代码只需要进行一些调整（加上PasteSpecial ！）就可以正常工作：

Sub select_blank()
    Dim cel As Range
    With ActiveSheet
        'specify that the range to be processed is from row 2 to the
        'last used cell in column A
        For Each cel In .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            If IsEmpty(cel.Value) Then
                'If the cell is empty, copy columns B:F
                cel.Offset(, 1).Resize(, 5).Copy
            Else
                'If the cell is not empty, paste the values previously copied
                'NOTE: This relies on cell A2 being empty!!
                cel.Offset(, 1).PasteSpecial
            End If
        Next
    End With
    Application.CutCopyMode = False
End Sub

Answer 2

我无法完全理解您想要的东西，它似乎与自己矛盾。 但是，由于我非常怀疑还有其他人会（按照规则）为您提供帮助，因此我将为您提供更好的开始。

Sub Test()
  Dim nRow As Integer

  nRow = 1

  Do Until Range("A" & nRow) = "" And Range("A" & nRow + 1) = ""
    If Range("A" & nRow) = "" Then
    ' do stuff here in the loop

    End If
    nRow = nRow + 1
  Loop

End Sub

Answer 3

Sub copyRange()
    Dim rngDB As Range, vDB, rng As Range

    Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
    For Each rng In rngDB
        If rng = "" Then
            vDB = rng.Offset(, 1).Resize(1, 4)
        Else
            rng.Offset(, 1).Resize(1, 4) = vDB
        End If
    Next rng

End Sub