Использование инструмента транспонирования в Excel для большого столбца значений

Question

У меня есть очень большой лист данных с именами и адресами. Прямо сейчас это выглядит примерно так:

               Name   Number       Address
                                   Address
                                   Address
                                  (Address)

Существуют сотни и сотни подобных групп, и все они разделены хотя бы одной пустой строкой. Теперь я могу использовать инструмент транспонирования вручную, но это займет у меня довольно много времени. Я думал о том, чтобы просто написать макрос для этого, однако некоторые адреса состоят из трех строк, а некоторые из четырех строк, поэтому меня это смущает, если это вообще возможно.

Любые простые способы сделать это без необходимости делать все это вручную?

Answer 1

Теперь я предполагаю, что вы хотите, чтобы конечный результат выглядел примерно так, как показано ниже, без строк между людьми и полного адреса в одной строке в одной ячейке

Name    Number  Address
Name    Number  Address
Name    Number  Address
Name    Number  Address
Name    Number  Address
Name    Number  Address

я также собираюсь предположить, что ваши данные начинаются в ячейке A1 и что каждое имя уникально. если этого не произойдет, макрос нуждается в незначительной настройке. установите Stopper = 50000 на строку после вашего последнего набора данных, иначе это может продолжаться гораздо дольше, чем необходимо (или, возможно, не достаточно долго).

Sub CollectThem()
    Dim All As New Collection
    Dim One As Variant
    Dim Addy As Variant, Stopper As Long, L1 As Integer

    Stopper = 645

    Cells(1, 1).Select
    Do Until ActiveCell.Row >= Stopper
        ReDim One(0 To 2)
        One(0) = ActiveCell.Offset(0, 0).Value
        One(1) = ActiveCell.Offset(0, 1).Value
        Addy = ""
        Do Until ActiveCell.Row >= Stopper Or (ActiveCell.Value <> "" And ActiveCell.Value <> One(0))
            Addy = Addy & ActiveCell.Offset(0, 2).Value & "|"
            ActiveCell.Offset(1, 0).Select
        Loop
        One(2) = Trim(Addy)
        All.Add One
        Erase One
    Loop

    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Select

    Cells(1, 1).Select
    For Stopper = 1 To All.Count
        One = All(Stopper)
        ActiveCell.Offset(0, 0).Value = One(0)
        ActiveCell.Offset(0, 1).Value = One(1)
        Addy = Split(One(2), "|")
        If IsArray(Addy) Then
            For L1 = 0 To UBound(Addy)
                ActiveCell.Offset(0, 2 + L1).Value = Addy(L1)
            Next L1
            Erase Addy
        Else
            ActiveCell.Offset(0, 2).Value = One(2)
        End If
        ActiveCell.Offset(1, 0).Select
        Erase One
    Next Stopper
End Sub