Question

基本上我有3列，每列都有自己的空行不规则空间（它们实际上是从数据透视表中复制的行标签，3层）。

我想让每个值填充它们下面的空行和下面的下一行标签重复复制＆amp;对于所有3行，粘贴例程，一直到结束。我打算从我选择的活动单元格开始运行宏，所以我应该运行宏3次，每列一次。

我已经尝试过我的手并最终得到了以下代码，但它没有给我我想要的东西，任何帮助都将不胜感激。

Sub LoopCopyPaste()

Application.Goto Reference:="LoopCopyPaste"

Do Until Selection.Value = "(blank)"

    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveCell.Offset(-1, 0).Select
    ActiveSheet.Paste
    Selection.End(xlDown).Select
    Application.CutCopyMode = False

Loop

End Sub

Answer 1

这是一个有效的解决方案。即使我不理解它背后的需要，这还是一个有趣的问题！

Sub replaceBlanks()

' define variables
Dim column As Integer
Dim row As Integer
Dim lastRow As Integer
Dim previousValue As String
Dim value As String

' stop screen from updating to speed things up
Application.ScreenUpdating = False

' use the active sheet
With ActiveSheet

    ' get the current cell selected and the last row in column selected
    column = ActiveCell.column
    row = ActiveCell.row
    lastRow = .Cells(.Rows.Count, column).End(xlUp).row

    ' set previous value to the first cell
    previousValue = Cells(row, column).value

    ' iterate for every row between selected and last row with data in
    For i = row To lastRow
        ' set value = the content of that cell
        value = Cells(i, column).value
        ' if it contains nothing
        If Len(value) < 1 Then
            ' set the value of cell equal to the previous cell that had something in it
            Cells(i, column).value = previousValue
        ' if it contains something
        Else
            ' update the previous value and move on to next row
            previousValue = value
        End If

    Next i

End With

' update the screen at the end
Application.ScreenUpdating = True

End Sub

循环复制并正确粘贴

1 个答案: