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

我有成千上万的数据行，如下面的Excel示例＃1所示。 所有的数据都在列A中。每个“数据组”都有六行：名称，date，城市，县，州和空白行。 我需要将列A中的每个名称下的数据移动到列B到E中，如行1和行2所示。然后，我需要删除每个名称下面的五行，以便将单元格向上移动，以便最终输出看起来像目前在第1行和第2行的数据。

EXCEL SAMPLE #1- ABCDE 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> 

这里是我创build移动数据的Excel 2010macros。 问题是，我不知道如何改变“范围”，以便它拿起下一组数据。 我的公式只适用于macros指定范围内的数据。

 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

这是一个你应该可以运行多次你想要的，即使你添加新的数据。 我没有testing过，所以请谨慎行事。

 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