Объединить столбцы в соответствии с ключами Excel

Question

Нужно конвертировать

Невозможно изменить вышеприведенное, чтобы mtown и waco повторялись для каждой строки, так как он заблокирован и импортируется из другого места.

Окончательный результат / отчет должен выглядеть следующим образом:

Хотите сделать это, используя формулы Excel, но не можете понять это.

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

---

РЕДАКТИРОВАТЬ: Включенное изображение с индексами строк и столбцов

Answer 1

Также вы можете попробовать:

Option Explicit

Sub X()

    Dim LR As Long, i As Long, j As Long
    Dim rngName As String

    With Worksheets("Sheet1")

        LR = .Cells(.Rows.Count, "B").End(xlUp).Row
        For j = 1 To LR
            If .Cells(j, 1).Value <> "" And Cells(j, 2).Value <> "" Then
                rngName = .Cells(j, 1).Value

                .Cells(j, 2).Select

                Do Until IsEmpty(ActiveCell)
                    If ActiveCell.Offset(, -1).Value <> "" And ActiveCell.Offset(1, -1).Value = "" Then
                        ActiveCell.Offset(1, -1).Value = ActiveCell.Value
                        ActiveCell.Clear
                    ElseIf ActiveCell.Offset(, -1).Value <> "" And ActiveCell.Offset(1, -1).Value <> "" Then
                        ActiveCell.Offset(1, 1).EntireRow.Resize(2).Insert Shift:=xlDown
                        ActiveCell.Offset(1, -1).Value = ActiveCell.Value
                        ActiveCell.Offset(2, -1) = rngName
                        ActiveCell.Clear
                    End If

                   ActiveCell.Offset(1, 0).Select

                Loop

                ActiveCell.Offset(1, -1) = rngName

            End If
        Next j

    End With

End Sub

Answer 2

Вот быстрый способ сделать это на VBA.

Sub FreakyPeopleFormat()

    Dim rngCell As Range 'cell we are processing
    Dim location As String 'waco, mtown
    Dim lastCell As Integer 'last populated cell on the sheet
    Dim writeCell As Range 'cell to write to

    'set initial write cell
    Set writeCell = Sheet1.Range("F2")

    'get the last cell
    lastCell = Sheet1.Range("C" & Sheet1.Rows.Count).End(xlUp).Row()

    'loop through the data
    For Each rngCell In Sheet1.Range("C2:C" & lastCell)

        'capture location if it's changed
        If location <> rngCell.Offset(, -1).Value And rngCell.Offset(, -1).Value <> "" Then
            If location <> "" Then 'write it out again
                writeCell.Value = location
                'move to next cell and write location
                Set writeCell = writeCell.Offset(1)
            End If

            'capture and write out location
            location = rngCell.Offset(, -1).Value
            writeCell.Value = location
            Set writeCell = writeCell.Offset(1)
        End If

        'process the line
        writeCell.Value = rngCell.Value

        'increment the writeCell
        Set writeCell = writeCell.Offset(1)
    Next

    'finally write out the location once more
    writeCell.Value = location
End Sub