2

我需要一个 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

进入

COL A    COL B 
100 ---- PC 245, PC 246, PC 247
101 ---- PC 245, PC 246, PC 247

该数据将进入地图，因此我需要将其连接到工具提示文本中。任何帮助表示赞赏。谢谢！

PS：我需要的是一个宏。我不需要的是数据透视表。

4

2 回答 2

4

重新发布此代码，因为它已被版主删除。@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
于 2012-11-13T17:26:17.393 回答
0

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

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

它可以使用“集合”而不是“字典”。我只是更喜欢字典。

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

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

然后它遍历收集的数据并将其输出到现在为空的工作表（“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
于 2012-11-13T05:10:04.093 回答