将数据行移动到列，然后删除行

Question

我有数千行数据，如下面的 Excel 示例 #1 所示。所有数据目前都在 A 列中。每个“组”数据有六行：姓名、日期、城市、县、州和一个空白行。我需要将 A 列中每个名称下的数据移动到 B 到 E 列中，如第 1 行和第 2 行所示。然后我需要删除每个名称下方的五行以使单元格上升，以便最终输出看起来像当前位于第 1 行和第 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>

这是我创建的用于移动数据的 Excel 2010 宏。问题是我无法弄清楚如何更改“范围”以便它获取下一组数据。我的公式仅适用于宏中指定范围内的数据。

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

奇怪，这还没有回答。 :)

你只需要将你的逻辑放入一个循环中，我更喜欢使用Do..While...loop，所以我们开始吧：

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

祝你好运！

Answer 2

即使您添加了新数据，您也应该可以运行任意多次。我还没有测试过，所以请谨慎操作。

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