vba EXCEL：合并多行宏
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/13353080/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
EXCEL: Merge Multiple Rows Macro
提问by John C. Osborn
I need a MACRO that looks at all instances of COL A and combines all values of COL B into one row, while deleting the duplicates in the process. Adding a comma is a plus.
我需要一个 MACRO 来查看 COL A 的所有实例并将 COL B 的所有值合并为一行，同时删除过程中的重复项。添加逗号是一个加号。
I don't know any VBA, but if someone is kind enough to explain, I would love to learn. This isn't the first VBA solution I've needed. Thanks!
我不会任何 VBA，但如果有人愿意解释，我很乐意学习。这不是我需要的第一个 VBA 解决方案。谢谢！
Example of what I need:
我需要的示例：
COL A COL B
100 ---- PC 245
100 ---- PC 246
100 ---- PC 247
101 ---- PC 245
101 ---- PC 246
101 ---- PC 247
INTO
进入
COL A COL B
100 ---- PC 245, PC 246, PC 247
101 ---- PC 245, PC 246, PC 247
This data is going into a map, so I need it concatenated for the tooltip text. Any help is appreciated. Thanks!
此数据将进入地图，因此我需要将其连接到工具提示文本中。任何帮助表示赞赏。谢谢！
PS: What I need is a MACRO. What I don't need is a PIVOT TABLE.
PS：我需要的是一个宏。我不需要的是数据透视表。
回答by nutsch
Reposting this code as it was deleted by a moderator. @bill-the-lizard, prior to redeleting it, can you comment on what's wrong with my answer?
重新发布此代码，因为它已被版主删除。@bill-the-lizard，在重新删除它之前，您能评论一下我的回答有什么问题吗？
Sub ConsolidateRows()
'takes rows and consolidate one or many cells, based on one or many cells matching with above or below rows.
Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant
'**********PARAMETERS TO UPDATE****************
Const strMatch As String = "A" 'columns that need to match for consolidation, separated by commas
Const strConcat As String = "B" 'columns that need consolidating, separated by commas
Const strSep As String = ", " 'string that will separate the consolidated values
'*************END PARAMETERS*******************
application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes
colMatch = Split(strMatch, ",")
colConcat = Split(strConcat, ",")
lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row
For i = lastRow To 2 Step -1 'loop from last Row to one
For j = 0 To UBound(colMatch)
If Cells(i, colMatch(j)) <> Cells(i - 1, colMatch(j)) Then GoTo nxti
Next
For j = 0 To UBound(colConcat)
Cells(i - 1, colConcat(j)) = Cells(i - 1, colConcat(j)) & strSep & Cells(i, colConcat(j))
Next
Rows(i).Delete
nxti:
Next
application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub
回答by NickSlash
The following code requires you to add a reference to "Microsoft Scripting Runtime".
以下代码要求您添加对“Microsoft Scripting Runtime”的引用。
VBA Editor->Tools->References, Find and select Microsoft Scripting Runtime
Its possible to use "Collections" instead of "Dictionarys". I just prefer the dictionary.
可以使用“Collections”而不是“Dictionarys”。我只是更喜欢字典。
The code will read the active worksheet, (the "Do Loop") and copies the data (removing duplicates in the process)
代码将读取活动工作表（“Do Loop”）并复制数据（删除过程中的重复项）
It then clears alldata on the sheet.
然后它会清除工作表上的所有数据。
It then loops through the data it collected and outputs it to the now empty worksheet (the "For Each" loops)
然后循环遍历它收集的数据并将其输出到现在为空的工作表（“For Each”循环）
Sub Cat()
Dim Data As Dictionary
Dim Sheet As Worksheet
Set Sheet = ThisWorkbook.ActiveSheet
Set Data = New Dictionary
Dim Row As Integer
Dim Key As Variant
Dim Keys() As Variant
Dim Value As Variant
Dim Values() As Variant
Dim List As String
Row = 1
Do
If Data.Exists(CStr(Sheet.Cells(Row, 1))) Then
If Not Data(CStr(Sheet.Cells(Row, 1))).Exists(CStr(Sheet.Cells(Row, 2))) Then
Data(CStr(Sheet.Cells(Row, 1))).Add (CStr(Sheet.Cells(Row, 2))), True
End If
Else
Data.Add CStr(Sheet.Cells(Row, 1)), New Dictionary
Data(CStr(Sheet.Cells(Row, 1))).Add (CStr(Sheet.Cells(Row, 2))), True
End If
Row = Row + 1
If IsEmpty(Sheet.Cells(Row, 1)) Then
Exit Do
End If
Loop
Sheet.Cells.ClearContents
Keys = Data.Keys
Row = 1
For Each Key In Keys
Values = Data(Key).Keys
Sheet.Cells(Row, 1) = Key
List = ""
For Each Value In Values
If List = "" Then
List = Value
Else
List = List & ", " & Value
End If
Next Value
Sheet.Cells(Row, 2) = List
Row = Row + 1
Next Key
End Sub
