Unable to write a Macro for Excel VBA to copy a sp

Question

I have an excel spreadsheet with a value followed by exactly 29 spaces. I am trying to find a way to copy that value to the next 29 blank row spaces then loop again and copy the next value to the following 29 spaces.

Each value is different and there is no sequential order. I have over 50,000 rows and I have spent so much time trying to find a way to do this. Any help is much appreciated. I believe I can run a loop to accomplish this however I am a newb. Thank you!

Answer 1

The following should get you where you need to go. Post again with details if you run into any problems with it:

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