关键词删除重复的去重问题，请高手帮忙解答

supermantlm

老板要我处理一份关键词表，去除重复的关键词。EXCEL软件有自带的去重功能，但是需要完全匹配才可以删除重复值。像毛衣女和女毛衣这种关键词就无法用系统功能去除，请大神给个能用的公式，帮忙解决一下。。。先感谢了！要求像以下这类词都识别为重复词
毛衣女
女毛衣
毛衣   女
衣  毛   女
毛  女衣
女 毛衣

kevinchengcw

试下
Sub test()
Dim Arr, N&, I&, Str$
With ThisWorkbook.Worksheets("sheet1")
    Arr = .Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row).Value
    ReDim Preserve Arr(LBound(Arr) To UBound(Arr), LBound(Arr, 2) To UBound(Arr, 2) + 2)
    With CreateObject("vbscript.regexp")
        .Global = True
        .ignorecase = True
        For N = LBound(Arr) + 1 To UBound(Arr)
            For I = LBound(Arr) To N - 1
                If Arr(I, 1) <> "" And Arr(I, 2) = "" Then
                    Str = "[" & Arr(I, 1) & "\s]+"
                    .Pattern = Str
                    If Len(.Replace(Arr(N, 1), "")) = 0 Then
                        Str = "[" & Arr(N, 1) & "\s]+"
                        .Pattern = Str
                        If Len(.Replace(Arr(I, 1), "")) = 0 Then
                            Arr(N, 2) = "重复"
                            Arr(N, 3) = Arr(I, 1)
                        End If
                    End If
                End If
            Next I
        Next N
    End With
    .[a2].Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
End With
End Sub

supermantlm

kevinchengcw 发表于 2019-10-12 13:49
试下
Sub test()
Dim Arr, N&, I&, Str$

感谢大哥，我去试下。VBA还不会用。。。

supermantlm

kevinchengcw 发表于 2019-10-12 13:49
试下
Sub test()
Dim Arr, N&, I&, Str$

刚试了下，不对呢，最后一行的毛衣女 针织也被识别出来了
劳烦再帮我看看问题出在哪里

ykqrs

1. Sub qq()
   
2. Dim Arr, I%, j%, brr() As Byte, d, s$, x%, aa, zf$, crr, r%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Range("b2:c1000") = ""
   
5. r = Cells(Rows.Count, 1).End(xlUp).Row
   
6. Arr = Range("a1:c" & r)
   
7. ReDim crr(1 To UBound(Arr), 1 To 1)
   
8. For I = 2 To UBound(Arr)
   
9. s = Replace(Arr(I, 1), " ", "")
   
10. brr = s
    
11. For j = 0 To UBound(brr) - 1
    
12. For x = j + 1 To UBound(brr)
    
13. If brr(j) > brr(x) Then aa = brr(j): brr(j) = brr(x): brr(x) = aa
    
14. Next
    
15. Next
    
16. zf = brr: crr(I, 1) = zf
    
17. d(crr(I, 1)) = d(crr(I, 1)) & "," & I
    
18. Next
    
19. For I = 2 To UBound(Arr)
    
20. crr(I, 1) = d(crr(I, 1))
    
21. aa = Split(crr(I, 1), ",")
    
22. If UBound(aa) > 1 Then
    
23. Arr(I, 2) = "重复": Arr(I, 3) = Arr(aa(1), 1)
    
24. End If
    
25. Next
    
26. Range("a1:c" & r) = Arr
    
27. End Sub
    

复制代码

supermantlm

ykqrs 发表于 2019-10-12 15:14

真棒，试了一下全出来了，佩服大哥！！我再多加点关键词验证一下，非常感谢你的帮助

ykqrs

这个针织毛衣女和毛衣女针织不应该显示出来吗

supermantlm

ykqrs 发表于 2019-10-12 15:14

大哥，还有个问题，我A列数据还要大量的加入，这个代码通用吗？
关键词多达上万个

ykqrs

supermantlm 发表于 2019-10-12 15:20
大哥，还有个问题，我A列数据还要大量的加入，这个代码通用吗？
关键词多达上万个

应该没问题，速度不知道如何？

supermantlm

好厉害~~~我多试试！！！解决了我一个大麻烦，谢了！！