用数组法和字典法找内容重复项

shchint

老师们好，我是小白，有感于VBA的强大，最近在学习VBA，但对代码不太懂，老师们能不能帮忙写两个例子，分别用数组法和字典法对两列找重复，用最简单的代码实现，最好能在每行代码后面说明该行的意思，方便新手学习，先谢过老师们了。


最简单的两列找重复方法.rar (10.41 KB, 下载次数: 18)

2023-3-20 11:47 上传

点击文件名下载附件

cjc209

字典法就非常简单

shchint

cjc209 发表于 2023-3-20 11:52
字典法就非常简单

老师，请亮出你的绝招

cjc209

字典法                        

cjc209

第二个 For i = 2 To n 改成For i = 2 To n1

sxbjzjf110

参与一下。。。。

leolee82

数组的方法是先排序，再把挨在一起相同的去掉，再恢复原来的顺序。代码不写了，很长

gwjkkkkk

Option Explicit
Sub test1() '数组
    Dim ar, br, i&, j&
   
    With [A2].CurrentRegion
        ar = .Value
        .Interior.ColorIndex = xlNone
        For i = 1 To UBound(ar)
            If ar(i, 2) <> "" Then
                For j = 1 To UBound(ar)
                    If ar(j, 1) = ar(i, 2) Then
                        .Cells(j, 1).Interior.Color = vbYellow
                        .Cells(i, 3) = ar(j, 1)
                        Exit For
                    End If
                Next j
            End If
        Next i
    End With
    Beep
End Sub
Sub test2() '字典
    Dim ar, i&, dic As Object
        
    Set dic = CreateObject("Scripting.Dictionary")
    With [A2].CurrentRegion
        ar = .Value
        .Interior.ColorIndex = xlNone
        For i = 1 To UBound(ar): dic(ar(i, 1)) = i: Next
        For i = 1 To UBound(ar)
            If dic.exists(ar(i, 2)) Then
                .Cells(i, 3) = ar(i, 2)
                .Cells(dic(ar(i, 2)), 1).Interior.Color = vbYellow
            End If
        Next i
    End With
    Beep
End Sub

gwjkkkkk

二种方法参与一下。。。

fzxba

1. Sub test0() '数组 参与
   
2.   Dim vData, ar(), br(), cr
   
3.   Dim i As Long, j As Long, k As Long, s As String
   
4.   With Range("A1").CurrentRegion.Resize(, 3)
   
5.     .Columns(3).ClearContents
   
6.     .Interior.Color = xlNone
   
7.     vData = .Value
   
8.   End With
   
9.   On Error Resume Next
   
10.   For j = 2 To 1 Step -1
    
11.     k = 0
    
12.     For i = 2 To UBound(vData)
    
13.       s = vData(i, j)
    
14.       If Len(s) Then
    
15.         cr = Filter(ar, s)
    
16.         If j = 2 Then
    
17.           If UBound(cr) = -1 Then
    
18.             k = k + 1
    
19.             ReDim Preserve ar(1 To k)
    
20.             ar(k) = s
    
21.           End If
    
22.         Else
    
23.           If UBound(cr) <> -1 Then
    
24.             k = k + 1
    
25.             ReDim Preserve br(1 To k)
    
26.             br(k) = s
    
27.             Cells(i, j).Interior.Color = 255
    
28.           End If
    
29.         End If
    
30.       End If
    
31.     Next
    
32.   Next
    
33.   Range("C2").Resize(k) = WorksheetFunction.Transpose(br)
    
34.   Err.Clear: Beep
    
35. End Sub

复制代码