求一段格式调整的vba代码，，去除重复内容

ykcbf1100

NieC 发表于 2024-4-5 15:36
感谢。因为是一个变量的内容，所以用字典还需要对字符做处理。。

没有附件，一般不参与，大家都很忙。

NieC

ykcbf1100 发表于 2024-4-5 15:39
没有附件，一般不参与，大家都很忙。

明白，打扰了

ooluckydog

Sub 格式转换()

    Dim regex As Object
    Set regex = CreateObject("vbscript.regexp")
    Dim d As Object
    Dim arr() As Variant
    Dim i As Long, k As Long
    Dim sKey As Variant
    Dim c As Collection
   
    Set d = CreateObject("scripting.dictionary")
   
    arr = Sheet1.[a1].CurrentRegion.Value
   
    With regex
        .Global = True
        .Pattern = "^【[一-龢]+】"
        For i = 1 To UBound(arr)
            If .test(arr(i, 1)) Then
                sKey = .Execute(arr(i, 1))(0)
                If Not d.exists(sKey) Then
                    Set c = New Collection
                    c.Add .Replace(arr(i, 1), "")
                    Set d(sKey) = c
                Else
                    d(sKey).Add .Replace(arr(i, 1), "")
                End If
            End If
        Next i
    End With
   
    With Sheet1
        For Each sKey In d
            k = k + 1
            .Cells(k, "D") = sKey
            For i = 1 To d(sKey).Count
                k = k + 1
                .Cells(k, "D") = d(sKey).Item(i)
            Next i
        Next
    End With
   
End Sub

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, r&, aMatch As Object, dic As Object, vKey
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    ReDim br(1 To UBound(ar) * 2, 0)
    With CreateObject("VBScript.RegExp")
        .Pattern = "【.+?】"
        For i = 1 To UBound(ar)
            If .test(ar(i, 1)) Then
                Set aMatch = .Execute(ar(i, 1))(0)
                dic(aMatch.Value) = dic(aMatch.Value) & "," & .Replace(ar(i, 1), "")
            End If
        Next i
    End With
   
    For Each vKey In dic.keys
        r = r + 1
        br(r, 0) = vKey
        ar = Split(dic(vKey), ",")
        For j = 1 To UBound(ar)
            r = r + 1
            br(r, 0) = ar(j)
        Next j
    Next
   
    Columns("B").Clear
    [B1].Resize(r) = br
    Beep
End Sub

gwjkkkkk

参与一下....

lizhipei78

用函数来非常简单
C1=UNIQUE(A:A)
D1=TEXTJOIN(CHAR(10),1,FILTER(B:B,A:A=C1))
记得选中单元格设置自动换行