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

• Запишите макрос, назначьте горячую клавишу макроса, затем выполните задачи
• Скопировать> вставить специальный> транспонировать> поместить курсор [введите]
• объединить (&) текст, как этот Джо удар, главный хончо с формулами
• = M5 & "" & M6 & "," & M7
  • где эти ячейки содержат 4 записи. и двойные кавычки содержат пробел и

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

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

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

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

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

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

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

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

Обязательно переименуйте этот cCompanyInfo

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 

Результаты :