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

Question

嗨，我是VBA的新手并且遇到了障碍。尝试用我理解的小片拼凑代码片段，但想想我已经超出了我的想象。我非常感谢构建代码块以实现以下目标的任何帮助：

在以下工作表中

1. 我正在尝试遍历A列并识别任何空白单元格。

2. 如果单元格为空白，我想复制A列中空白单元格右侧相邻4个单元格范围内的值。例如：如果循环将A2标识为空白单元格，则循环将复制范围内的值（“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