excel - 无法为 Excel VBA 编写宏以将特定单元格值复制到下一个空白行

Question

我有一个 excel 电子表格，其值后跟 29 个空格。我试图找到一种方法将该值复制到接下来的 29 个空白行空间，然后再次循环并将下一个值复制到以下 29 个空格。

每个值都是不同的，没有顺序。我有超过 50,000 行，我花了很多时间试图找到一种方法来做到这一点。任何帮助深表感谢。我相信我可以运行一个循环来完成这个，但是我是一个新手。谢谢！

Answer 1

以下内容应该可以帮助您到达需要去的地方。如果您遇到任何问题，请再次发布详细信息：

Sub Copy29Rows()

Dim wks As Excel.Worksheet
Dim rng_Source As Excel.Range, rng_target As Excel.Range

'Change this to the name of the worksheet that you're working with
Set wks = ThisWorkbook.Worksheets("Sheet2")

'Change the sheet and cell name to whatever your original source is.
Set rng_Source = wks.Range("A1")

'Check that there is a value to copy
If rng_Source.Value = "" Then
    MsgBox "There are no values to copy"
    GoTo ExitPoint
End If

'We keep looping until we find no further values.
Do While rng_Source.Value <> ""

    'Make sure that you don't run off the end of the sheet
    If rng_Source.Row + 29 > wks.Rows.Count Then
        Err.Raise vbObjectError + 20000, , "There aren't enough empty rows in the sheet to copy down 29 rows."
    End If

    'The target will be offset one row from the value that we're
    'copying and will be 29 rows high.
    Set rng_target = rng_Source.Offset(1, 0).Resize(29, rng_Source.Columns.Count)

    'Now copy the original value and paste it into the target range
    rng_Source.Copy rng_target

    'Finally move the source 30 rows down.
    Set rng_Source = rng_Source.Offset(30, 0)

Loop

ExitPoint:
On Error Resume Next
Set rng_Source = Nothing
Set rng_target = Nothing
Set wks = Nothing
On Error GoTo 0

Exit Sub

ErrorHandler:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description

Resume ExitPoint

End Sub