excel - 特定のセル値を次の空白行にコピーするためのExcelVBAのマクロを記述できません

Question

値の後に正確に29個のスペースが続くExcelスプレッドシートがあります。その値を次の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