把两列数据相比较，把含有相同的数据保留

mmwwdd

mmwwdd

看着挺简单，实际也挺费脑子

mmwwdd

这是数学中排列组合的问题，如果用多重循环也行，但是效率低下

fzxba

1. Sub testDictionary()
   
2.   Dim ar, br(9) As String, s As String, t As String
   
3.   Dim i As Long, j As Long, k As Long, r As Long, x As Long
   
4.   
   
5.   Dim Dict As Object
   
6.   Set Dict = CreateObject("Scripting.Dictionary")
   
7.   
   
8.   ar = Range("B2").CurrentRegion.Resize(, 2)
   
9.   
   
10.   For j = 1 To UBound(ar, 2)
    
11.     For i = 1 To UBound(ar)
    
12.       s = Trim(ar(i, j))
    
13.       If Len(s) Then
    
14.         For k = 1 To Len(s)
    
15.           x = Val(Mid(s, k, 1)):   br(x) = br(x) & x
    
16.         Next
    
17.         t = Join(br, vbNullString)
    
18.         If j = 1 Then
    
19.           If Not Dict.Exists(t) Then Dict.Add t, vbNullString
    
20.         Else
    
21.           If Dict.Exists(t) Then:    r = r + 1:    ar(r, 1) = s:    'Dict.Remove t
    
22.         End If
    
23.       End If
    
24.       Erase br
    
25.     Next
    
26.   Next
    
27.   
    
28.   With Range("F2")
    
29.     .CurrentRegion.ClearContents
    
30.     .Resize(r) = ar
    
31.   End With
    
32.   
    
33.   Set Dict = Nothing
    
34.   Beep
    
35. End Sub

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim arrlist As Object
   
5.     Dim d As Object
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set arrlist = CreateObject("system.collections.arraylist")
   
8.     With Worksheets("01")
   
9.         r = Application.Max(.Cells(.Rows.Count, 2).End(xlUp).Row, .Cells(.Rows.Count, 3).End(xlUp).Row)
   
10.         arr = .Range("b2:c" & r)
    
11.         For j = 1 To 2
    
12.             For i = 1 To UBound(arr)
    
13.                 If Len(arr(i, j)) <> 0 Then
    
14.                     arrlist.Clear
    
15.                     For k = 1 To Len(arr(i, j))
    
16.                         ch = Val(Mid(arr(i, j), k, 1))
    
17.                         arrlist.Add ch
    
18.                     Next
    
19.                     arrlist.Sort
    
20.                     ss = Join(arrlist.toarray, "")
    
21.                     If Not d.exists(ss) Then
    
22.                         Set d(ss) = CreateObject("scripting.dictionary")
    
23.                     End If
    
24.                     d(ss)(j) = arr(i, j)
    
25.                 End If
    
26.             Next
    
27.         Next
    
28.         ReDim brr(1 To UBound(arr) * 2, 1 To 1)
    
29.         m = 0
    
30.         For Each aa In d.keys
    
31.             If d(aa).Count = 2 Then
    
32.                 m = m + 1
    
33.                 brr(m, 1) = d(aa)(1)
    
34.             End If
    
35.         Next
    
36.         .Range("f2:f" & .Rows.Count).ClearContents
    
37.         .Range("f2").Resize(m, 1) = brr
    
38.     End With
    
39. End Sub
    

复制代码

chxw68

参与一下。

lizhipei78

lizhipei78

参与一下
把含有相同的数据保留.rar (17.94 KB, 下载次数: 4)

2023-2-23 12:32 上传

点击文件名下载附件