请教字符串去重复

鄂龙蒙

请教：表中A列是有规律用逗号相隔的字符，想去重复达到B列的效果。
本人试写了代码，但去重出现累加问题，怎么处理？谢谢！

字符串去重复.rar (10.09 KB, 下载次数: 47)

2017-9-10 10:10 上传

点击文件名下载附件

yaozong

Sub 字符去重复2()
Dim d, arr, i&, j&, n&
Set d = CreateObject("Scripting.Dictionary")
arr = [A2:A10]
For i = 1 To UBound(arr)
  p = Split(arr(i, 1), ",")
  For j = 0 To UBound(p)
    If Not d.exists(p(j)) Then
      s = s & "," & p(j)
      d(p(j)) = ""
    End If
  Next
  arr(i, 1) = Mid(s, 2)
  s = ""
  d.RemoveAll
Next
[d2].Resize(UBound(arr), 1) = arr
Set d = Nothing
End Sub

microyip

1. Sub 字符去重复ByMicro()
   
2.     Dim vData As Variant, nRow As Integer
   
3.     Dim dicData As Object, vDic As Variant, nDic As Integer
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Set dicData = CreateObject("Scripting.Dictionary")
   
7.     vData = Sheet4.UsedRange.Offset(1).Resize(, 1).Value
   
8.     For nRow = 1 To UBound(vData) - 1
   
9.         vDic = Split(vData(nRow, 1), ",")
   
10.         dicData.RemoveAll
    
11.         For nDic = 0 To UBound(vDic)
    
12.             dicData(vDic(nDic)) = 0
    
13.         Next
    
14.         vData(nRow, 1) = ""
    
15.         For Each vDic In dicData
    
16.             If vData(nRow, 1) <> "" Then vData(nRow, 1) = vData(nRow, 1) & ","
    
17.             vData(nRow, 1) = vData(nRow, 1) & vDic
    
18.         Next
    
19.     Next
    
20.     Sheet4.[C2].Resize(UBound(vData) - 1) = vData
    
21. End Sub

复制代码

wzsy2_mrf

不需词典

1. Sub 字符去重复()
   
2.     Dim br, i, j, brr(), s, p
   
3.     Sheet4.Range("C1:C10000").ClearContents
   
4.     br = Sheet4.Range("A2:A10")
   
5.     For i = 1 To UBound(br)
   
6.         p = Split(br(i, 1), ",")
   
7.         s = ""
   
8.         For j = 0 To UBound(p)
   
9.             If InStr(s, p(j)) = 0 Then
   
10.                 s = s & "," & p(j)
    
11.             End If
    
12.         Next
    
13.         br(i, 1) = Right(s, Len(s) - 1)
    
14.     Next
    
15.     Sheet4.[C2].Resize(UBound(br), 1) = br
    
16. End Sub
    

复制代码

duquancai

Sub 字符去重复()
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        s = Split(arr(i, 1), ",")
        For j = 0 To UBound(s)
            d(s(j)) = ""
        Next
        arr(i, 1) = Join(d.keys(), ",")
        d.RemoveAll
    Next
    arr(1, 1) = "想要的结果【去重复保留唯一的】"
    [a1].CurrentRegion.Offset(, 1).ClearContents
    [b1].Resize(UBound(arr), 1) = arr
End Sub

准提部林

wzsy2_mrf 发表于 2017-9-10 11:41
不需词典

如果是 BAA1,AA1,A1,A1

後面的AA1,A1都會被吃掉~~

AmoKat

Sub 字符去重複_AmoKat()
    Dim xR As Range, S$, i%
    Set xR = Cells(2, 1)
    Do While xR <> ""
        Arr = Split(xR, ",")
        For i = 0 To UBound(Arr)
            If Application.Match(Arr(i), Arr, 0) = i + 1 Then S = S & IIf(S = "", "", ",") & Arr(i)
        Next
        xR(1, 3) = S: S = ""
        Set xR = xR(2, 1)
    Loop
End Sub

准提部林

另類法:
Sub test1()
Dim xR As Range, AA, T$, i%
For Each xR In Range([A2], [A65536].End(xlUp))
　　AA = Split(xR, ",")
　　For i = UBound(AA) To 0 Step -1
　　　　T = AA(i) & " " & Trim(Replace(" " & T & " ", " " & AA(i) & " ", " "))
　　Next i
　　xR(1, 3) = Replace(Trim(T), " ", ","): T = ""
Next
End Sub
　
　

AmoKat

也可以用自訂函數來處理
Function StrRmvDmp(Str)
    S = Split(Str, ",")
    Set d = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(S): d(S(i)) = i: Next
    StrRmvDmp = Join(d.keys(), ",")
End Function

Sub ex1()
    With [F2].Resize(Application.CountA([A:A]))
        .Value = "=StrRmvDmp(A2)"
        .Value = .Value
    End With
End Sub

准提部林

INSTR法：
Sub test2()
Dim xR As Range, AA, T$
For Each xR In Range([A2], [A65536].End(xlUp))
　　For Each AA In Split(xR, ",")
　　　　If InStr("," & T & ",", "," & AA & ",") = 0 Then T = T & "," & AA
　　Next
　　xR(1, 3) = Mid(T, 2): T = ""
Next
End Sub