VBA 字符串的分部去重并组合

yhy95331

B列为需处理的字符串，现想将字符串分割成前三后十，前3个字符串去重复，字符从小到大排列，后10个字符串与前三个字符串作比较，相同部分去除，也从小到大排列，并将前三后十字符串处理后的结果合并，放入D列。有点难度，求大师帮忙处理一下。

3190496160

代码不能写，关键是循环太多，速度就是问题

liulang0808

Sub 按钮1_Click()
    r = Cells(Rows.Count, 2).End(3).Row
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    arr = [b1].Resize(r, 2)
    For j = 3 To UBound(arr)
        arr(j, 2) = ""
        If Len(arr(j, 1)) > 0 Then
            brr = Split(Trim(arr(j, 1)), " ")
            d.RemoveAll
            dd.RemoveAll
            For i = 0 To 2
                d(Int(brr(i))) = ""
            Next i
            For i = 2 To UBound(brr)
                If Not d.exists(Int(brr(i))) Then
                    dd(Int(brr(i))) = ""
                End If
            Next i
            str1 = ""

            For i = 1 To d.Count
                str1 = str1 & " " & WorksheetFunction.Small(d.keys, i)
            Next i
            arr(j, 1) = Trim(str1)
            str1 = ""
            For i = 1 To dd.Count
                str1 = str1 & " " & WorksheetFunction.Small(dd.keys, i)
            Next i
            arr(j, 2) = Trim(str1)
        End If
    Next j
    [k1].Resize(r, 2) = arr
End Sub

liulang0808

附件内容供参考。。。。。。

fzxba

Sub test1()
  Dim a, b$(9), c$(9), i&, j%, n%, s$
  a = Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)
  For i = 1 To UBound(a)
    Erase b, c
    s = Replace(Trim(a(i, 1)), Space(1), vbNullString)
    For j = 1 To Len(s)
      n = Val(Mid(s, j, 1))
      If j > 3 Then
        If Len(b(n)) = 0 Then c(n) = n
      Else
        b(n) = n
      End If
    Next
    a(i, 1) = WorksheetFunction.Trim(Join(b) & Space(1) & Join(c))
  Next
  Range("E3").Resize(UBound(a)) = a
End Sub

perfect131

既然是数字，那就用数组序号去重法

jz_l

yhy95331

感谢各位大师，运行符合结果

usedrange

参与一下，看看是不是楼主想要的

yhy95331

usedrange 发表于 2022-11-24 17:58
参与一下，看看是不是楼主想要的

谢谢大师，运行顺畅，今日花花已送完，明日再送