将数据行移至列，然后删除行

Question

I have thousands of rows of data as shown in the Excel Sample #1 below. All data is currently in Column A. Each "Group" of data has six lines: name, dates, city, county, state and a blank line. I need to move the data under each Name in Column A into Columns B through E as shown in Rows 1 and 2. I need to then delete the five rows below each name to bring the cells up so that the final output would look like the data currently in Rows 1 and 2.

EXCEL SAMPLE #1-
     A        B      C      D      E
 1 Name1    Dates1 City1 County1 State1
 2 Name2    Dates2 City2 County2 State2 
 3 Name3
 4 Dates3
 5 City3
 6 County3
 7 State3
 8 <blank row>
 9 Name4
10 Dates4
11 City4
12 County4
13 State4
14 <blank row>

Here is the Excel 2010 macro I created to move the data. The problem is that I cannot figure out how to change the “ranges” so that it picks up the next Group of data. My formula only works on the data in the ranges specified in the macro.

Sub Move_Rows()
'
' Move_Rows Macro
' Moves cemetery row data for each grave into separate columns
'
' Keyboard Shortcut: Ctrl+q
'
    Range("A111:A115").Select
    Selection.Copy
    Range("B110").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A111:A115").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub

Answer 1

Strange that this was not answered yet. :)

All you need is to put your logic into a loop, I prefer using Do..While...loop , so here we go:

Sub Move_Rows()
'
' Move_Rows Macro
' Moves cemetery row data for each grave into separate columns
'
' Keyboard Shortcut: Ctrl+q
'
    Application.ScreenUpdating = False

    i = 111 'Initial row number
    Do While Cells(i, "A") <> ""
        Range(Cells(i, "A"), Cells(i+4, "A")).Select
        Selection.Copy
        Cells(i-1, "B").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Range(Cells(i, "A"), Cells(i+4, "A")).Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp
        i = i + 1
    loop

    Application.ScreenUpdating = True
End Sub

Have a good luck with that!

Answer 2

Here's one that you should be able to run however many times you want, even if you add new data. I haven't tested it, so proceed with caution.

Sub Move_Rows()
    Dim ws As Worksheet
    Dim rRng As Range ' keep track of where we're gonna paste the results
    Dim sRng As Range, eRng As Range ' start-range, end-range

    Set ws = ThisWorkbook.Worksheets(1) ' <~~ Change to whatever you need

    For i = 1 To ws.UsedRange.Rows.Count
        ' Is this row valid as start of a range? If the cell in col B is populated, this means the current row is already correctly "formatted" and we need to skip it.
        If (ws.Range("B" & i).Value = "") And (sRng Is Nothing) Then
            Set rRng = ws.Range("B" & i)
            Set sRng = ws.Range("A" & i).Offset(1, 0) ' start-range set to the row below, we don't need to transpose the name.
        End If

        ' Is this row valid as end of a range? If the cell in col A is empty, the previous range will be the end of the area we want to copy.
        If ws.Range("A" & i).Value = "" Then
            Set eRng = ws.Range("A" & i).Offset(-1, 0) ' end-range set to the row above, we don't want to transpose the empty cell.

            ' The row was empty and we've set the reference to the content above. Now we can delete the empty row.
            ws.Range("A" & i).EntireRow.Delete
        End If

        If (Not sRng Is Nothing) And (Not eRng Is Nothing) Then ' You can also move this inside the previous If-loop. I prefer having it outside for readability.
            ' We have both a start-range and an end-range, we should do the copy-paste now
            Range(sRng, eRng).Copy
            rRng.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

            ' Delete the now-superfluous rows
            Range(sRng, eRng).EntireRow.Delete

            ' Empty the range variables so we don't get wrong matches next iteration.
            Set rRng = Nothing
            Set sRng = Nothing
            Set eRng = Nothing
        Else
            ' One of the ranges are empty, so we'll do nothing. You can remove this line and the Else.
        End If
    ' Go to the next row
    Next i
End Sub