Excel группирует несколько столбцов и транспонирует

Question

У меня есть таблица Excel, заполненная компаниями, филиалами, данными компаний и контактами.

Я пытаюсь сгруппировать данные по одной и той же компании и городу филиала, затем транспонировать, так что в каждом отдельном столбце у меня будет информация заголовка Company/Branch, затем contact1, contact2, contact3 и т. д. Затем, в следующем столбце, следующая информация заголовка Company/Branch, затем ее контакты. У каждого контакта должны быть объединены имя, фамилия и должность, и они должны быть отсортированы по имени, фамилии.

Я хотел бы делать это регулярно для данных (первый выстрел), так как они будут часто меняться. Лучше ли это сделать с помощью формул, VBA, Pivot table? Любая помощь будет оценена.

РЕДАКТИРОВАТЬ
Просто добавим все шаги для элегантного решения Рона ниже:
1. Сохраните рабочий лист в формате Macro-enabled (.xlsm) worksheet
2. Убедитесь, что основной лист называется sheet1
3. Создайте пустой целевой лист с именем sheet2
4. Откройте редактор VBA (Alt-F11)
5. Нажмите Вставка, Модуль класса, затем вставьте код модуля класса
6. Нажмите F4, чтобы просмотреть окно свойств модуля класса, затем в поле Имя измените его на cCompanyInfo
7. Нажмите Вставка, Модуль, затем вставьте код обычного модуля
8. Нажмите Инструменты, Ссылки, затем найдите Microsoft Scripting Runtime, установите флажок и нажмите ОК
9. Вернитесь на рабочий лист, нажмите Alt-F8, чтобы просмотреть макрос, и нажмите Выполнить.

sheet2 будет заполнен отформатированными данными.

Вы также можете назначить сочетание клавиш для запуска макроса с помощью кнопки Параметры в диалоговом окне просмотра макроса

Answer 1

• Запишите макрос, назначьте горячую клавишу макроса, затем выполните задачи
• Копировать > специальная вставка > транспонировать > поместить курсор [enter]
• объединить (&) текст как этотДжо Блоу, главный боссс формулами
• "="М5&" "&М6&", "&М7
  • где эти ячейки содержат 4 записи, а двойные кавычки содержат пробел и запятую

Answer 2

Я внес несколько изменений в ваши исходные данные.

В частности, я добавил последнюю строку, в которой есть ABC Corp.но, расположенное не по порядку, а также отличающееся Noteот других записей.

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

Для телефонных номеров я удалил нечисловые элементы, чтобы они все отображались в единообразном формате, если они не вводятся единообразно. Вам может потребоваться изменить этот алгоритм в зависимости от изменчивости ваших реальных данных.

Я сделал некоторое форматирование, чтобы результаты выглядели "красиво". Вы можете предпочесть ничего или другое форматирование. Вам также может потребоваться настроить имена рабочих листов в обычном модуле.

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

Исходные данные:

Модуль класса

Обязательно переименуйте этоcИнформация о компании

Option Explicit
'Rename this class module:  cCompanyInfo

Const dictKey = 1
Const dictItem = 2

Private pCompany As String
Private pBranch As String
Private pPhone As Currency
Private pNote As String
Private pNotes As Dictionary
Private pFirstName As String
Private pLastName As String
Private pTitle As String
Private pNameTitles As Dictionary

Public Property Get Company() As String
    Company = pCompany
End Property
Public Property Let Company(Value As String)
    pCompany = Value
End Property

Public Property Get Branch() As String
    Branch = pBranch
End Property
Public Property Let Branch(Value As String)
    pBranch = Value
End Property

Public Property Get Phone() As Currency
    Phone = pPhone
End Property
Public Property Let Phone(Value As Currency)
    pPhone = Value
End Property

Public Property Get Note() As String
    Note = pNote
End Property
Public Property Let Note(Value As String)
    pNote = Value
End Property

Public Property Get FirstName() As String
    FirstName = pFirstName
End Property
Public Property Let FirstName(Value As String)
    pFirstName = Value
End Property

Public Property Get LastName() As String
    LastName = pLastName
End Property
Public Property Let LastName(Value As String)
    pLastName = Value
End Property

Public Property Get Title() As String
    Title = pTitle
End Property
Public Property Let Title(Value As String)
    pTitle = Value
End Property

Public Property Get Notes() As Dictionary
    Set Notes = pNotes
End Property
Public Function ADDNote(Value As String)
    If Not pNotes.Exists(Value) Then pNotes.Add Value, Value
End Function

Public Property Get NameTitles() As Dictionary
    Set NameTitles = pNameTitles
End Property
Public Function ADDNameTitle(S As String)
    If Not pNameTitles.Exists(S) Then pNameTitles.Add S, S
End Function

Private Sub Class_Initialize()
    Set pNotes = New Dictionary
    Set pNameTitles = New Dictionary
End Sub

'Dictionary Sort routine
'Shamelessly copied From  https://support.microsoft.com/en-us/kb/246067

Public Sub SortDictionary(objDict, intSort)
  ' declare our variables
  Dim strDict()
  Dim objKey
  Dim strKey, strItem
  Dim X, Y, Z

  ' get the dictionary count
  Z = objDict.Count

  ' we need more than one item to warrant sorting
  If Z > 1 Then
    ' create an array to store dictionary information
    ReDim strDict(Z, 2)
    X = 0
    ' populate the string array
    For Each objKey In objDict
        strDict(X, dictKey) = CStr(objKey)
        strDict(X, dictItem) = CStr(objDict(objKey))
        X = X + 1
    Next

    ' perform a a shell sort of the string array
    For X = 0 To (Z - 2)
      For Y = X To (Z - 1)
        If StrComp(strDict(X, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
            strKey = strDict(X, dictKey)
            strItem = strDict(X, dictItem)
            strDict(X, dictKey) = strDict(Y, dictKey)
            strDict(X, dictItem) = strDict(Y, dictItem)
            strDict(Y, dictKey) = strKey
            strDict(Y, dictItem) = strItem
        End If
      Next
    Next

    ' erase the contents of the dictionary object
    objDict.RemoveAll

    ' repopulate the dictionary with the sorted information
    For X = 0 To (Z - 1)
      objDict.Add strDict(X, dictKey), strDict(X, dictItem)
    Next

  End If

End Sub

Регулярный модуль

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub ConsolidateCompanyInfo()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cCI As cCompanyInfo, dictCI As Dictionary
    Dim sNT As String
    Dim I As Long, J As Long, L As Currency, S As String
    Dim LastRow As Long, LastCol As Long

'Change worksheets names as appropriate
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'Read the data into an array
With wsSrc
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

'Organize and Collect the data
Set dictCI = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cCI = New cCompanyInfo
    With cCI
        .Company = vSrc(I, 1)
        .Branch = vSrc(I, 2)

        'Remove non-numeric characters from phone number for consistency
        'might need to add other Replace functions, or use Regex
        L = Replace(vSrc(I, 3), "-", "")

        .Phone = L
        .Note = vSrc(I, 4)
        .ADDNote .Note
        .FirstName = vSrc(I, 5)
        .LastName = vSrc(I, 6)
        .Title = vSrc(I, 7)
        sNT = .FirstName & " " & .LastName & ", " & .Title
        .ADDNameTitle sNT
        S = .Company & "|" & .Branch
        If Not dictCI.Exists(S) Then
            dictCI.Add S, cCI
        Else
            dictCI(S).ADDNote .Note
            dictCI(S).ADDNameTitle sNT
        End If
    End With
Next I

'Populate Results array
Dim V, W
I = 0

'First need to size the sections
Const lHeader As Long = 3 'Name, Branch, Phone number Rows
Dim lNotes As Long
Dim lContacts As Long

For Each V In dictCI
    With dictCI(V)
        lNotes = IIf(lNotes > .Notes.Count, lNotes, .Notes.Count)
        lContacts = IIf(lContacts > .NameTitles.Count, lContacts, .NameTitles.Count)
    End With
Next V

ReDim vRes(1 To lHeader + 1 + lNotes + 1 + lContacts, 1 To dictCI.Count)

J = 0
For Each V In dictCI
    J = J + 1
    With dictCI(V)
        vRes(1, J) = .Company
        vRes(2, J) = .Branch
        vRes(3, J) = .Phone
        I = lHeader + 1

        For Each W In .Notes
            I = I + 1
            vRes(I, J) = .Notes(W)
        Next W

        I = lHeader + 1 + lNotes + 1

        .SortDictionary .NameTitles, 1
        For Each W In .NameTitles
            I = I + 1
            vRes(I, J) = .NameTitles(W)
        Next W
    End With

Next V

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

    'Do some formatting to pretty things up
    'You could certainly do something different
    Range(.Rows(1), .Rows(lHeader)).Style = "Input"
    Range(.Rows(lHeader + 2), .Rows(lHeader + 1 + lNotes)).Style = "Note"
    Range(.Rows(lHeader + 1 + lNotes + 2), .Rows(lHeader + 1 + lNotes + 1 + lContacts)).Style = "Output"
    With .Rows(3)  'Format the phone number
        .NumberFormat = "000-000-0000"
        .HorizontalAlignment = xlLeft
    End With
    .EntireColumn.AutoFit
End With

End Sub

Полученные результаты: