Comparer 2 colonnes ADODB vs Dictionnaire

**Oliv-** · 16/11/2012, 12h58

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.

**tototiti2008** · 16/11/2012, 14h17

Bonjour Oliv,

Pas un spécialiste, mais le INNER JOIN dans le SQL va demander qu'il parcoure toutes les lignes de ta feuille1 (s1) pour trouver toutes les occurrences correspondantes, alors qu'a priori tu souhaites juste savoir si ça existe
EXISTS permet justement de s'arrêter dès qu'une valeur est trouvée, ce qui devrait être légèrement moins long

peut-être un truc du genre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
SELECT distinct s2.SIREN FROM [" & S2.Name & "$] s2 where exists 
(Select s1.siren from [" & S1.name & "$] s1 where s1.SIREN = S2.SIREN)

**Oliv-** · 16/11/2012, 14h51

Merci tototiti2008 cette partie va vraiment très vite
inner join vs exist testé sur sql server , ca se vaut..

En fait, je recherche plus les limites à cette façon de faire, par exemple, il faut que les données soient en "Tableau" et commencent à la ligne 2 (l1 étant le titre utilisé comme nom de colonne).

**tototiti2008** · 16/11/2012, 16h35

Re,

Sinon peut-être envisager de tout faire en SQL ?

un essai sur la base de ton code

Edit : Oups, modifier les données source il n'aime pas trop, correction
Ci-joint un classeur exemple sur base de ton code
Données sources en Feuil1 et Feuil2
Résultats en Feuil3 et Feuil4

**Oliv-** · 16/11/2012, 22h39

C'est effectivement super rapide.

Dans la réalité par contre les colonnes ne sont pas isolées elles sont parmis d'autres colonnes.
SIREN|NOM|ADRESSE|... etc soit plusieurs dizaines de colonnes.
Donc je dois remettre à la bonne place le résultat.

dans le SR2 c'est trié par ordre croissant !?

J'observe un effet de bord étrange, en lançant "mon code" puis un second basé sur des dictionnaires le second code qui met environ 11 sec s'il est exécuté en premier voit son temps d’exécution x10 !!!!

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
Option Explicit
Public S1 As Worksheet
Public S2 As Worksheet
Public SR As Worksheet
 
 
 
 
Sub Dictionnaire()
    Dim t, truc, temp, i
    Dim mondico As Object
    Dim mondicoCommun As Object
    t = Timer
    Set mondico = CreateObject("Scripting.Dictionary")
    Set mondicoCommun = CreateObject("Scripting.Dictionary")
 
 
    Set S1 = Worksheets("Feuil1")
    Set S2 = Worksheets("Feuil2")
 
    If S2.UsedRange.Rows.Count < S1.UsedRange.Rows.Count Then
        Set SR = S1
        Set S1 = S2
        Set S2 = SR
        Set SR = Nothing
    End If
 
 
 
    For Each truc In S1.Range("A2", S1.Cells(Rows.Count, 1).End(xlUp))
        If Not mondico.Exists(truc.Value) Then mondico.Add truc.Value, truc.Value
    Next truc
 
    For Each truc In S2.Range("A2", S2.Cells(Rows.Count, 1).End(xlUp))
        If mondico.Exists(truc.Value) Then mondicoCommun.Add truc.Value, truc.Value
    Next truc
 
Debug.Print Timer - t
Debug.Print mondico.Count
Debug.Print mondicoCommun.Count
    Application.StatusBar = mondicoCommun.Count
Application.ScreenUpdating = False
    For i = 2 To S1.Cells(Rows.Count, 1).End(xlUp).Row
        If mondicoCommun.Exists(S1.Cells(i, 1).Value) Then
            S1.Cells(i, 2).Value = "OK"
        Else: S1.Cells(i, 2).Value = "ko"
        End If
    Next i
 
    For i = 2 To S2.Cells(Rows.Count, 1).End(xlUp).Row
        If mondicoCommun.Exists(S2.Cells(i, 1).Value) Then
            S2.Cells(i, 2).Value = "OK"
        Else: S2.Cells(i, 2).Value = "ko"
        End If
    Next i
Application.ScreenUpdating = True
Debug.Print Timer - t
    MsgBox Timer - t
 
End Sub

**patricktoulon** · 17/11/2012, 16h22

bonjour oliv+

un truc que je ne comprend pas cest
pourquoi genere tu 2 dico alors que tu te sert de qu'un seul

puisque tu compare dicocommun a s(xy).cell(x,y)et no pas a dico

au plaisir

Comparer 2 colonnes ADODB vs Dictionnaire [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager