我有一张 Excel 表，里面满是公司、分支机构、公司数据和联系人。
我尝试将数据按同一公司和分公司所在城市分组，然后进行转置，这样在每一列中我都有公司/分公司标题信息，然后是联系人 1、联系人 2、联系人 3 等。然后，下一列是下一个公司/分公司标题信息，然后是其联系人。每个联系人应该有他们的名字和姓氏以及衔接的头衔，并应按名字和姓氏排序。
我想定期针对给定的数据执行此操作（第一次尝试），因为它会经常更改。最好使用公式、VBA、数据透视表来完成此操作吗？任何帮助都将不胜感激。
编辑
下面仅添加 Ron 优雅解决方案的所有步骤：
1. 将工作表保存为启用宏 (.xlsm) 的工作表
2. 确保主工作表名为 sheet1
3. 创建一个名为 sheet2 的空白目标工作表
4. 打开 VBA 编辑器 (Alt-F11)
5. 单击插入、类模块，然后粘贴类模块代码
6. 按 F4 查看类模块的属性窗口，然后在名称字段中将其更改为 cCompanyInfo
7. 单击插入、模块，然后粘贴常规模块代码
8. 单击工具、引用，然后找到 Microsoft Scripting Runtime，选中复选框并单击确定
9. 返回工作表，按 Alt-F8 查看宏，然后单击运行。sheet2
将填充格式化的数据。
您还可以使用视图宏对话框上的选项按钮分配键盘快捷键来运行宏
答案1
- 录制宏，分配宏热键，然后执行任务
- 复制 > 选择性粘贴 > 转置 > 放置光标 [enter]
- 像这样连接（&）文本乔·布洛，首席大佬使用公式
- =M5&“ “&M6&“，”&M7
- 这些单元格包含 4 个条目。双引号包含空格和逗号
答案2
我对您的原始数据做了一些更改。
具体来说，我添加了最后一行，其中有一个但顺序混乱，并且与其他条目 ABC Corp.也不同。Note
您可以看到在编码中如何处理这个问题，并且如果有必要，如果您有不同的电话号码，您可以使用类似的技术。
对于电话号码，我删除了非数字元素，以便它们都可以以一致的格式显示，以防输入不一致。您可能需要修改此算法，具体取决于实际数据的变化。
我进行了一些格式化，以使结果“看起来不错”。您可能更喜欢无格式或不同的格式您可能还需要调整常规模块中的工作表名称。
请务必阅读并理解代码和注释，以便将来能够维护这一点。
原始数据：
类模块
请务必重命名此公司信息
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
结果：
