高手来呀：怎么删重复单元格

ing170

使用removeduplicates只能把一些简单的重复的单元格去掉，怎么才能做到下面的效果：
a1:苹果手机
a2:手机苹果
a3:机手果苹
只要单元格内字符元素相同位置不同的，就是重复单元格，保留其中任意一个就行，其它的都去掉，怎么做到的呢？

ing170

有回复吗，

sheeboard

用的是python的方法

1. def to_set(x):
   
2.     a=set(list(x))
   
3.     return ''.join(a）
   
4. 
   
5. df['temp']=df['phone'].apply(to_set)
   
6. 
   
7. n [85]: df
   
8. Out[85]:
   
9.    id phone  temp
   
10. 0  a1  苹果手机  机果手苹
    
11. 1  a2  手机苹果  机果手苹
    
12. 2  a3  机手果苹  机果手苹
    
13. 
    
14. df=df.drop_duplicates('temp')
    
15. df=df.drop('temp',axis=1)
    
16. 
    
17. 结果
    
18. In [99]: df
    
19. Out[99]:
    
20.    id phone
    
21. 0  a1  苹果手机
    
22. 
    

复制代码

一把小刀闯天下

ing170 发表于 2018-7-26 13:59
有回复吗，

'如果有重复的保留第一次出现的
'如果有重复的保留第一次出现的

Option Explicit

Sub test()
  Dim arr, i, j, k, n, t
  arr = [a1].CurrentRegion
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) Then
      For j = i + 1 To UBound(arr, 1)
        If Len(arr(j, 1)) = Len(arr(i, 1)) Then
          For k = 1 To Len(arr(j, 1))
            If InStr(arr(i, 1), Mid(arr(j, 1), k, 1)) = 0 Then Exit For
          Next
          If k = Len(arr(j, 1)) + 1 Then arr(j, 1) = vbNullString
        End If
      Next
      n = n + 1: arr(n, 1) = arr(i, 1)
    End If
  Next
  With [b1]
    .Resize(Rows.Count).ClearContents
    .Resize(n) = arr
  End With
End Sub

mzbao

我下面的代码是将每个字的ASCII码值加起来，然后创建字典，判断重复值。

1. Sub test()
   
2.     Dim i%, j%, txt$, sumCode As Long
   
3.     Dim d
   
4.    
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     For i = 1 To 3
   
7.         txt = Cells(i, 1).Value
   
8.         sumCode = 0
   
9.         For j = 1 To Len(txt)
   
10.             sumCode = sumCode + Asc(Mid(txt, j, 1))
    
11.         Next
    
12.         If Not d.Exists(sumCode) Then
    
13.             d(sumCode) = 1
    
14.         Else
    
15.             Cells(i, 1).ClearContents
    
16.         End If
    
17.     Next
    
18. End Sub

复制代码

这代码有可能会判断不准，毕竟2+2和1+3是一样的，但是你每个汉字的ASCII码值合计相等的概率应该非常低。
代码只有关键的部分，其它需要你自己补全。

zhjlgaojuan

没有好的思路,来个暴力的,本来不好意思贴出来的,想了想,贴出来或许会勾引高手来指点一下也说不定
Sub test()
Dim SourceArr, TargetArr(), Mydic1 As Object, Mydic2 As Object
Set Mydic1 = CreateObject("scripting.dictionary")
Set Mydic2 = CreateObject("scripting.dictionary")
SourceArr = [a1].CurrentRegion
ReDim TargetArr(1 To UBound(SourceArr), 1 To UBound(SourceArr, 2))
For i = 1 To UBound(SourceArr)
    For j = 1 To UBound(SourceArr, 2)
        For x = IIf(j = UBound(SourceArr, 2), i + 1, i) To UBound(SourceArr)
            For y = IIf(x = i, j + 1, 1) To UBound(SourceArr, 2)
                If Len(SourceArr(i, j)) = Len(SourceArr(x, y)) Then
                    Z = 0
                    For k = 1 To Len(SourceArr(i, j))
                        Mydic1(Mid(SourceArr(i, j), k, 1)) = 0
                        Mydic2(Mid(SourceArr(i, j), k, 1)) = 0
                    Next
                    For k = 1 To Len(SourceArr(i, j))
                        Mydic1(Mid(SourceArr(i, j), k, 1)) = Mydic1(Mid(SourceArr(i, j), k, 1)) + 1
                    Next
                    For k = 1 To Len(SourceArr(x, y))
                        Mydic2(Mid(SourceArr(x, y), k, 1)) = Mydic2(Mid(SourceArr(x, y), k, 1)) + 1
                    Next
                    For k = 1 To Len(SourceArr(i, j))
                        If Mydic1(Mid(SourceArr(i, j), k, 1)) = Mydic2(Mid(SourceArr(i, j), k, 1)) Then Z = Z + 1
                    Next
                    If Z = Len(SourceArr(i, j)) Then TargetArr(x, y) = 1
                End If
            Next
        Next
    Next
Next
'测试用,只是标注,没有删除
For i = 1 To UBound(TargetArr)
    For j = 1 To UBound(TargetArr, 2)
        If TargetArr(i, j) = 1 Then Cells(i, j).Interior.Color = 255
    Next
Next
End Sub

zhenghui13

每个人的思路都不一样。我是将字符串1存入数组，然后用字符串2去清除数组；如果最后数组为空，那么是匹配的，否则为不匹配。

1. Sub Main()
   
2. Dim Sk1$
   
3. Dim Sk2$
   
4. Dim i, m
   
5. Dim Flag As Boolean
   
6. With Sheet1
   
7. For i = 1 To 4
   
8.     Sk1 = .Cells(i, 1).Value
   
9.         m = i + 1
   
10.         Do While m <= 4
    
11.             Sk2 = .Cells(m, 1).Value
    
12.             If Check_String(Sk1, Sk2) Then
    
13.                 .Cells(i, 2) = "Y"
    
14.                 .Cells(m, 2) = "Y"
    
15.             End If
    
16.             m = m + 1
    
17.         Loop
    
18. Next i
    
19. End With
    
20. End Sub
    
21. 
    
22. Function Check_String(ByVal Str1$, Str2$) As Boolean
    
23. Dim Flag As Boolean
    
24. Dim i, j
    
25. Dim Arr
    
26. Dim Sk1$, Sk2$
    
27. If Not Len(Str1) = Len(Str2) Then Check_String = False: Exit Function
    
28. ReDim Arr(1 To Len(Str1))
    
29. For i = 1 To Len(Str1)
    
30.     Arr(i) = Mid(Str1, i, 1)
    
31. Next i
    
32. For j = 1 To Len(Str2)
    
33.     Sk2 = Mid(Str2, j, 1)
    
34.     For i = 1 To UBound(Arr)
    
35.         Sk1 = Arr(i)
    
36.         If Sk1 = Sk2 Then
    
37.             Arr(i) = ""
    
38.             Exit For
    
39.         End If
    
40.     Next i
    
41. Next j
    
42. For i = 1 To UBound(Arr)
    
43.     If Not Arr(i) = "" Then
    
44.         Check_String = False
    
45.         Exit Function
    
46.     End If
    
47. Next i
    
48. Check_String = True
    
49. End Function

复制代码

ing170

怎么对一列数据操作呢，如B列所有数据，

不知道为什么

ing170 发表于 2018-7-27 11:40
怎么对一列数据操作呢，如B列所有数据，

把上面的代码改下循环范围不就行了？

jiminyanyan

看起来简单的题。实现起来有一定难度。。。