VBA-查找重复项并合并第二列

我想要一个脚本，将第一列合并为键，并与第二列合并重复项（如果唯一）

例如

将是

Home | 1,2,3,4,5
Rome | 1,2,3

我如何做到这一点

尝试的代码：

    Sub test()
Dim teststring As String
Dim tarray As Variant
Dim separating As String

separating = ","
teststring = ""
rownum = 2

For i = 1 To 5

If teststring <> ActiveSheet.Cells(i, 1).Value Then
teststring = ActiveSheet.Cells(i, 1).Value
rownum = i
Else
tarray = Split(ActiveSheet.Cells(i, 2).Value, separating)


For k = 1 To UBound(tarray)

If InStr(1, ActiveSheet.Cells(rownum, 2).Value, tarray(k)) = 0 Then
ActiveSheet.Cells(rownum, 2).Value = ActiveSheet.Cells(rownum, 2).Value & separating & ActiveSheet.Cells(i, 2).Value
End If

Next k

End If


Next i


End Sub

子测试（）
将测试字符串设置为字符串
变暗焦油
像字符串一样分开
分隔“”，”
teststring=“”
rownum=2
对于i=1到5
如果测试字符串ActiveSheet.Cells（i，1）.Value，则
teststring=ActiveSheet.Cells（i，1）.Value
rownum=i
其他的
tarray=Split（ActiveSheet.Cells（i，2）.值，分隔）
对于k=1至UBound（tarray）
如果InStr（1，ActiveSheet.Cells（rownum，2）.Value，tarray（k））=0，那么
ActiveSheet.Cells（rownum，2）.Value=ActiveSheet.Cells（rownum，2）.Value&分隔&ActiveSheet.Cells（i，2）.Value
如果结束
下一个k
如果结束
接下来我
端接头

这段代码将合并行，按升序排序，并删除重复的行（如果输入中没有空格）。同样，副本也不必像您的示例中那样位于彼此下方。试试看，让我知道它是否适合你

Sub Merge()
Dim arr1() As String
Dim arr2() As String
Dim Separator As String
Dim i, s As Integer
Dim lastRow As Long

lastRow = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
s = 1
Separator = ","

For i = s + 1 To lastRow
    If ActiveSheet.Cells(s, 1).Value <> "" And ActiveSheet.Cells(s, 1).Value = ActiveSheet.Cells(i, 1).Value And s <> i Then
        arr1 = Split(ActiveSheet.Cells(s, 2).Value, Separator)
        arr2 = Split(ActiveSheet.Cells(i, 2).Value, Separator)
        ActiveSheet.Cells(s, 2).Value = Output(arr1(), arr2())
        ActiveSheet.Range(Cells(i, 1), Cells(i, 2)).ClearContents
        lastRow = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
    End If
    If i = lastRow Then
        If s = lastRow Then
            Exit For
        End If
        s = s + 1
        i = 0
    End If
Next i
End Sub


Function Output(arr1() As String, arr2() As String) As String
Dim x, y, z, Size1, Size2 As Integer
Dim strOutput As String
Dim arr3() As String

Size1 = UBound(arr1())
Size2 = UBound(arr2())

For x = 0 To Size1
    For y = 0 To Size2
        If arr1(x) = arr2(y) Then
            arr2(y) = "0"
        End If
    Next y
Next x

arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",")
arr3 = BubbleSort(arr3)

For z = 0 To UBound(arr3())
    If arr3(z) <> "0" Then
        strOutput = strOutput & "," & arr3(z)
    End If
Next z

Output = Right(strOutput, Len(strOutput) - 1)
End Function

Function BubbleSort(ByRef strArray() As String) As String()
   Dim z       As Long
   Dim i       As Long
   Dim strWert As Variant

    For z = UBound(strArray) - 1 To LBound(strArray) Step -1
        For i = LBound(strArray) To z
            If LCase(strArray(i)) > LCase(strArray(i + 1)) Then
                strWert = strArray(i)
                strArray(i) = strArray(i + 1)
                strArray(i + 1) = strWert
            End If
        Next i
    Next z

    BubbleSort = strArray
End Function

子合并（）
Dim arr1（）作为字符串
Dim arr2（）作为字符串
字符串分隔符
Dim i，s为整数
最后一排一样长
lastRow=工作表（“表1”）。单元格（Rows.Count，1）。结束（xlUp）。行
s=1
分隔符=“，”
对于i=s+1至最后一行
如果ActiveSheet.Cells（s，1）.Value“”和ActiveSheet.Cells（s，1）.Value=ActiveSheet.Cells（i，1）.Value和s i
arr1=拆分（ActiveSheet.Cells（s，2）.值，分隔符）
arr2=拆分（ActiveSheet.Cells（i，2）.值，分隔符）
ActiveSheet.Cells（s，2）.Value=输出（arr1（），arr2（））
范围（单元格（i，1），单元格（i，2））.ClearContent
lastRow=工作表（“表1”）。单元格（Rows.Count，1）。结束（xlUp）。行
如果结束
如果我=最后一行，那么
如果s=最后一行，则
退出
如果结束
s=s+1
i=0
如果结束
接下来我
端接头
函数输出（arr1（）作为字符串，arr2（）作为字符串）作为字符串
尺寸x、y、z、尺寸1、尺寸2为整数
作为字符串的暗输出
Dim arr3（）作为字符串
Size1=UBound（arr1（））
Size2=UBound（arr2（））
对于x=0到大小1
对于y=0到大小2
如果arr1（x）=arr2（y），则
arr2（y）=“0”
如果结束
下一个y
下一个x
arr3=拆分（联接（arr1，“，”&“，”&“，”&联接（arr2，“，”，”，”）
arr3=气泡运动（arr3）
对于z=0到UBound（arr3（））
如果arr3（z）“0”，则
strOutput=strOutput&“，”和arr3（z）
如果结束
下一个z
输出=右（strOutput，Len（strOutput）-1）
端函数
函数BubbleSort（ByRef strArray（）作为字符串）作为字符串（）
暗z一样长
我想我会坚持多久
尺寸strWert作为变型
对于z=UBound（strArray）-1至LBound（strArray）步骤-1
对于i=LBound（strArray）到z
如果LCase（strArray（i））>LCase（strArray（i+1）），那么
strWert=strArray（一）
strArray（i）=strArray（i+1）
strArray（i+1）=strWert
如果结束
接下来我
下一个z
泡泡糖
端函数

多种方式。你试过什么？发布任何代码。@SJR请查看已编辑的代码。好的，编写字典是一种方法。我现在没有时间发布代码，但如果在此期间没有其他人回答（这不太可能）。@SJR根据OP的历史记录，我不认为这不太可能。显然，他/她几乎从不接受答案，而支持票也同样稀少。因此，我（个人）不觉得有必要发布答案。@Ralph感谢Ralph的评论。。如果你再看远一点，你会发现我在这个网站上的活动非常有限，我已经接受了一些答案，有人给出的答案实际上回答了我的问题。。在大多数我没有回答的问题中，这是因为我要么回答了自己的问题，要么没有答案。我现在已经找到了答案，当我回到我的电脑前，我会把它贴出来。谢谢sjr的帮助，而不是试图贬低我

Sub Merge()
Dim arr1() As String
Dim arr2() As String
Dim Separator As String
Dim i, s As Integer
Dim lastRow As Long

lastRow = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
s = 1
Separator = ","

For i = s + 1 To lastRow
    If ActiveSheet.Cells(s, 1).Value <> "" And ActiveSheet.Cells(s, 1).Value = ActiveSheet.Cells(i, 1).Value And s <> i Then
        arr1 = Split(ActiveSheet.Cells(s, 2).Value, Separator)
        arr2 = Split(ActiveSheet.Cells(i, 2).Value, Separator)
        ActiveSheet.Cells(s, 2).Value = Output(arr1(), arr2())
        ActiveSheet.Range(Cells(i, 1), Cells(i, 2)).ClearContents
        lastRow = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
    End If
    If i = lastRow Then
        If s = lastRow Then
            Exit For
        End If
        s = s + 1
        i = 0
    End If
Next i
End Sub


Function Output(arr1() As String, arr2() As String) As String
Dim x, y, z, Size1, Size2 As Integer
Dim strOutput As String
Dim arr3() As String

Size1 = UBound(arr1())
Size2 = UBound(arr2())

For x = 0 To Size1
    For y = 0 To Size2
        If arr1(x) = arr2(y) Then
            arr2(y) = "0"
        End If
    Next y
Next x

arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",")
arr3 = BubbleSort(arr3)

For z = 0 To UBound(arr3())
    If arr3(z) <> "0" Then
        strOutput = strOutput & "," & arr3(z)
    End If
Next z

Output = Right(strOutput, Len(strOutput) - 1)
End Function

Function BubbleSort(ByRef strArray() As String) As String()
   Dim z       As Long
   Dim i       As Long
   Dim strWert As Variant

    For z = UBound(strArray) - 1 To LBound(strArray) Step -1
        For i = LBound(strArray) To z
            If LCase(strArray(i)) > LCase(strArray(i + 1)) Then
                strWert = strArray(i)
                strArray(i) = strArray(i + 1)
                strArray(i + 1) = strWert
            End If
        Next i
    Next z

    BubbleSort = strArray
End Function