Question

我需要一个MACRO来查看COL A的所有实例，并将COL B的所有值组合成一行，同时删除过程中的重复项。添加逗号是一个加号。

我不知道任何VBA，但如果有人善意解释，我很乐意学习。这不是我需要的第一个VBA解决方案。谢谢！

我需要的例子：

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

这些数据会进入地图，所以我需要连接工具提示文本。任何帮助表示赞赏。谢谢！

PS：我需要的是一个MACRO。我不需要的是PIVOT TABLE。

Answer 1

重新发布由主持人删除的代码。 @ 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

Answer 2

以下代码要求您添加对“Microsoft Scripting Runtime”的引用。

VBA Editor->Tools->References, Find and select Microsoft Scripting Runtime

可以使用“Collections”而不是“Dictionarys”。我只是喜欢这本字典。

代码将读取活动工作表（“Do循环”）并复制数据（删除过程中的重复项）

然后清除工作表上的所有数据。

然后循环遍历它收集的数据并将其输出到现在空的工作表（“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

EXCEL：合并多行宏

2 个答案: