Как сгруппировать список в excel?

Макрос VBA может генерировать результаты, а также список параметров для первого столбца результатов.

Чтобы ввести этот макрос (Sub), alt-F11 открывает редактор Visual Basic. Убедитесь, что ваш проект выделен в окне Проводника проектов. Затем в верхнем меню выберите Insert / Module и вставьте приведенный ниже код в открывшееся окно.

Обязательно установите ссылку, как указано в примечании в макросе

Чтобы использовать этот макрос (Sub), alt-F8 открывает диалоговое окно макроса. Выберите макрос по имени и запустите.

Этот макрос генерирует список со списком параметров в первом столбце. Его можно легко переписать, чтобы список параметров был в первой строке, если это предпочтительнее.

---

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub GroupLists()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dictParams As Dictionary
    Dim sParam As String
    Dim I As Long, J As Long, K As Long
    Dim V As Variant

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 5)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With

'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'row number for parameter
For I = 1 To UBound(vSrc, 1)
    J = J + 1 'column count
    Do
        If Not dictParams.Exists(vSrc(I, 1)) Then
            K = K + 1
            dictParams.Add Key:=vSrc(I, 1), Item:=K
        End If
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = ""

    If I > UBound(vSrc) Then Exit For
Next I

'Create results array
ReDim vRes(1 To dictParams.Count, 1 To J + 1)

'Populate Column 1
For Each V In dictParams.Keys
    vRes(dictParams(V), 1) = V
Next V

'Populate the data
J = 1 'column number
For I = 1 To UBound(vSrc, 1)
    J = J + 1
    Do
        sParam = vSrc(I, 1)
        vRes(dictParams(sParam), J) = vSrc(I, 2)
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = ""

    If I > UBound(vSrc) Then Exit For
Next I

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes

End Sub

---

EDIT: макрос изменен для отражения "реальных данных"

Пожалуйста, обратите внимание: вам нужно будет добавить второй лист для результатов. Я назвал его "Лист 2"

---

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub GroupLists()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dictParams As Dictionary
    Dim sParam As String
    Dim I As Long, J As Long, K As Long
    Dim V As Variant
    Dim sDelim As String 'Differentiates each record

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
    sDelim = vSrc(1, 1)
End With

'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'row number for parameter
For I = 1 To UBound(vSrc, 1)
    J = J + 1 'column count
    Do
        If Not dictParams.Exists(vSrc(I, 1)) Then
            K = K + 1
            dictParams.Add Key:=vSrc(I, 1), Item:=K
        End If
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = sDelim

    If I > UBound(vSrc) Then
        Exit For
    Else
        I = I - 1
    End If
Next I

'Create results array
ReDim vRes(1 To dictParams.Count, 1 To J + 1)

'Populate Column 1
For Each V In dictParams.Keys
    vRes(dictParams(V), 1) = V
Next V

'Populate the data
J = 1 'column number
For I = 1 To UBound(vSrc, 1)
    J = J + 1
    Do
        sParam = vSrc(I, 1)
        vRes(dictParams(sParam), J) = vSrc(I, 2)
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = sDelim

    If I > UBound(vSrc) Then
        Exit For
    Else
        I = I - 1
    End If
Next I

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes

End Sub

---

EDIT2: этот макрос является модификацией вышеприведенного, в котором перечислены результаты в противоположной ориентации. Это может оказаться более полезным.

---

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub GroupListsVertical()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dictParams As Dictionary
    Dim sParam As String
    Dim I As Long, J As Long, K As Long
    Dim V As Variant
    Dim sDelim As String 'Differentiates each record

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet3")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
    sDelim = vSrc(1, 1)
End With

'Get unique list of Parameters with row number
'Also count the number of entries for number of columns in final result
J = 0
Set dictParams = New Dictionary
K = 0 'column number for parameter
For I = 1 To UBound(vSrc, 1)
    J = J + 1 'row count
    Do
        If Not dictParams.Exists(vSrc(I, 1)) Then
            K = K + 1
            dictParams.Add Key:=vSrc(I, 1), Item:=K
        End If
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = sDelim

    If I > UBound(vSrc) Then
        Exit For
    Else
        I = I - 1
    End If
Next I

'Create results array
ReDim vRes(1 To J + 1, 1 To dictParams.Count)

'Populate row 1
For Each V In dictParams.Keys
    vRes(1, dictParams(V)) = V
Next V

'Populate the data
J = 1 'row number
For I = 1 To UBound(vSrc, 1)
    J = J + 1
    Do
        sParam = vSrc(I, 1)
        vRes(J, dictParams(sParam)) = vSrc(I, 2)
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop Until vSrc(I, 1) = sDelim

    If I > UBound(vSrc) Then
        Exit For
    Else
        I = I - 1
    End If
Next I

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.EntireColumn.Clear
rRes = vRes
rRes.EntireColumn.AutoFit


End Sub

---