Bonjour,
Je cherche à améliorer mon programme de comparaison.

Je vérifie chaque valeur d'une colonne (ici des SIREN) pour savoir si la valeur existe dans la seconde source.

Dans sa première version j'utilisais RECHERCHEV mais avec des temps de réponse assez long environ 4 min pour 20000 * 1500 cellules.

Là je teste l'utilisation de ADO :

Tout d'abord pour créer les sources (dans un classeur vide avec Feuil1,Feuil2,Feuil3)

dans un module
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 
Option Explicit
Sub création_sources()
 
    Dim maSource1(20000)
    Dim i
    maSource1(0) = "siren"
    For i = 1 To 20000
        maSource1(i) = CStr(1000000000 + i)
    Next i
    Worksheets("Feuil1").Range("A1").Resize(UBound(maSource1) + 1) = Application.Transpose(maSource1)
 
    Dim maSource2(4000)
    maSource2(0) = "siren"
    For i = 5 To 20000 Step 5
        If Right(CStr(i), 1) = "0" Then
 
            maSource2(i / 5) = CStr(1000000000 + i)
        Else
            maSource2(i / 5) = CStr(2000000000 + i)
        End If
    Next i
    Worksheets("Feuil2").Range("A1").Resize(UBound(maSource2) + 1) = Application.Transpose(maSource2)
 
End Sub
voici mon code
dans un autre module
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Option Explicit
Public S1 As Worksheet
Public S2 As Worksheet
Public SR As Worksheet
 
 
 
 
'---------------------------------------------------------------------------------------
' Procedure : Compare_with_ado
' Author    : OCTU
' Date      : 16/11/2012
' Purpose   : MACRO PRINCIPALE
'---------------------------------------------------------------------------------------
'
Sub Compare_with_ado()
    Dim cn As Object
    Dim rs As Object
    Dim strFile As String
    Dim strCon As String
    Dim strSQL As String
 
    Dim t0 As Double, t1 As Double
    t0 = Time
    t1 = Time
    Application.ScreenUpdating = False
 
    Set S1 = Worksheets("Feuil1")
    Set S2 = Worksheets("Feuil2")
    Set SR = Worksheets("Feuil3")    'Worksheets("SQL_COMMUNS")
 
    ''http://support.microsoft.com/kb/246335
 
    If ActiveWorkbook.Path = "" Then
        MsgBox "vous devez enregistrer ce fichier!"
        Exit Sub
    End If
 
    strFile = ActiveWorkbook.FullName
    ''Note HDR=Yes, the names in the first row of the range
    ''can be used.
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
           & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
 
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
 
    cn.Open strCon
 
    '-------------COMMUNS-----------------------------
    strSQL = "SELECT distinct s2.SIREN FROM [" & S2.Name & "$] s2 " _
           & "INNER JOIN [" & S1.Name & "$] s1 ON s2.SIREN=s1.SIREN"
 
    rs.Open strSQL, cn, 3, 3
    SR.Cells.Delete
    SR.Cells(1, 1).Value = S1.Cells(1, 1).Value
    SR.Cells(2, 1).CopyFromRecordset rs
    rs.Close
 
    cn.Close
    Call ssFiltre_surSql
    Application.ScreenUpdating = True
    MsgBox prompt:="Terminé ! : " + CStr(Time - t0)
End Sub
 
 
Sub ssFiltre_surSql()
'
' Filtre_surSql Macro
'
 
    Dim ResultatSQL As Range
    Set ResultatSQL = Range(SR.Range("A1"), SR.Cells(Rows.Count, 1).End(xlUp))
    '    ResultatSQL.Parent.Activate
    '    ResultatSQL.Select
 
    Dim S
    For Each S In Array(S1, S2)
        With S
            .Activate
            .Rows.Hidden = False
            If .FilterMode = True Then .ShowAllData
 
            .Range("B1").FormulaR1C1 = "COMPARAISON"
 
            With .Range("A2", Cells(Rows.Count, 1).End(xlUp)).Offset(0, 1)
                .Value = "ko"
                .Font.ColorIndex = xlAutomatic
            End With
 
            .UsedRange.Range("A1", Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                                                      ResultatSQL, Unique:=False
 
            With .Range("B2", Cells(Rows.Count, 2).End(xlUp)).SpecialCells(xlCellTypeVisible)
                .Value = "OK"
                .Font.Color = vbGreen
            End With
            .ShowAllData
        End With
 
    Next S
 
End Sub
en fait je voudrais une critique de celui-ci et des pistes d'amélioration de la vitesse d'exécution.