Переместить строки данных в столбцы, а затем удалить строки

Question

У меня есть тысячи строк данных, как показано в примере 1 примера Excel ниже. Все данные в настоящее время находятся в столбце 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 

Have удачи с этим!

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