Question

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

电子。 ģ

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

将是

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

Answer 1

这段代码将合并行，按升序对它们进行排序并删除重复项（如果输入中没有空格）。同样重复也不必像你的例子那样在彼此之下。尝试一下，让我知道它是否适合你。

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

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

1 个答案: