Discussion :

[Oliv-]

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]

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-]

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]

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-]

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]

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

[Oliv-]

Salut Patrick
C est une double comparaison ! Je veux les différences dans chaque source
Donc je cherche les communs
Peux tu tester mon pb de performance ?

[patricktoulon]

bonjour j'ai tres bien compris

sauf que dans le commun tu a forcement les truc des 2 pages du moins il me semble si j'ai bien lu le code

mais dans ta boucle2 sur s2 pourquoi n'utilise tu pas mondico au lieu de mondicocommun si c'est "ok" ok si "ko" s'est ko tout simplement

Code :

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

1
2
3
4
5
6
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

tu aurrais tout de suite la reponse

oupss... je viens de me rendre compte que non

Code :

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

1
2
3
4
5
 
For Each truc In S2.Range("A2", S2.Cells(Rows.Count, 1).End(xlUp))
  'rienque si il existe dans le dico1     
 If mondico.Exists(truc.Value) Then mondicoCommun.Add truc.Value, truc.Value
    Next truc

mais je pense le dicocommun est obsolete alors puisque qu'il peut y avoir que les meme chose que dico1

re

voila comment je vois les choses

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
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 mondico2 As Object
    t = Timer
    Set mondico = CreateObject("Scripting.Dictionary")
    Set mondico2 = CreateObject("Scripting.Dictionary")
 
 
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'question
bien que la je comprend pas tres bien 
 
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
 sa t'inverse les feuilles ok mais alors dans les futurs boucle sur les s1 et s2
 
les dicos ne seront pas les bons 
 il faut alors a mon avis inverser ici aussi les deux nom des dicos
 
sinon tu a une chance sur 2 de tomber avec le s2 avec dico2 ce qui serait inutile puisque dico2 est basé sur s2 au depart 
' fin de question
'c'est le pourquoi de tout ca que je ne comprend pas 
'pour moi un seul dico suffirai a detecter les difference 
'a moins que tu compare nonseulement les abcence mais aussi le row 'des 'item  
 
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
    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 Not mondico.Exists(truc.Value) Then mondico2.Add truc.Value, truc.Value
    Next truc
 
Debug.Print Timer - t
Debug.Print mondico.Count
Debug.Print mondico2.Count
    Application.StatusBar = mondicoCommun.Count
Application.ScreenUpdating = False
 
    'on compare donc la feuille 1 au dico2
    For i = 2 To S1.Cells(Rows.Count, 1).End(xlUp).Row
        If mondico2.Exists(S1.Cells(i, 1).Value) Then
            S1.Cells(i, 2).Value = "OK"
        Else: S1.Cells(i, 2).Value = "ko"
        End If
    Next i
 'on comparedonc la feuille 2 au dico1
    For i = 2 To S2.Cells(Rows.Count, 1).End(xlUp).Row
        If mondico.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

[Oliv-]

Patrick
Pour S2 tu as raison on peut directement mettre ok ou ko lors de l'ajout à dicocommun.

Pour cette partie là

Code :

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

1
2
3
4
5
6
    If S2.UsedRange.Rows.Count < S1.UsedRange.Rows.Count Then
        Set SR = S1
        Set S1 = S2
        Set S2 = SR
        Set SR = Nothing
    End If

je prend la liste la plus courte ca va plus vite comme je veux les communs au plus dans mon exemple j'ai 4000 communs
et pas d'incidence sur les 2 dicos

dicoCommun = Uniquement les communs aux 2
mondico = l'ensemble des valeurs de S1 dédoublonnées

[patricktoulon]

re

en fait ca depend comme je te l'ai dis

et non!!! c'est la plus longue qu'il faut prendre
il ce peut que la ligne 3257 dans s2 ai la valeur de a1 en s1

a moins que le critere du row de la cellule soit pris en compte au quel cas c'est la plus courte

et j'irrais meme plus loin
puisque tu boucle 4 fois sur tes cellule 2 pour s1 et 2 pour s2

au plus simple
en considerent que le row de la cellule fait partie du critere de comparaison

Code :

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

1
2
3
4
For truc = 1 To Cells.UsedRange.Rows
If S2.truc = S1.truc Then S2.truc.Offset(x, y) = "ok" Else: S2.truc.Offset(x, y) = "ko"
If S1.truc = S2.truc Then S1.truc.Offset(x, y) = "ok" Else: S1.truc.Offset(x, y) = "ko"
Next

et en conciderent que les valeur peuvent se trouver sur une cellule differente

Code :

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

1
2
3
4
5
6
7
8
9
10
 
For truc = 1 To S1.Cells.UsedRange.Rows
    For trucs2 = 1 To S2.Cells.UsedRange.Rows
        If S2.trucs2 = S1.truc Then
            S2.trucs2.Offset(x, y) = "ok": S1.truc.Offset(x, y) = "ok"
        Else:
            S2.trucs2.Offset(x, y) = "ko"
            S1.truc.Offset(x, y) = "ko"
        End If
    Next

ce n'est que l'idée de base
qu'en pense tu?
au plaisir

[Oliv-]

tu bosses trop patrick !! t'es fatigué

teste MA macro 1x puis en commentant

Code :

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

1
2
3
4
5
6
    If S2.UsedRange.Rows.Count < S1.UsedRange.Rows.Count Then
        Set SR = S1
        Set S1 = S2
        Set S2 = SR
        Set SR = Nothing
    End If

temps x3 !!!

Pour optimiser il faudrait que je copie mes 2 ranges dans des variables tableau , puis que je transpose à la fin.


Une autre façon de vérifier l'existence c'est de reprendre la méthode de "ssFiltre_surSql()" je met ko partout puis je filtre s1 par s2 je met les cellules visible à OK puis pareil S2 FILTR2 SUR S1 tout simplement , à voir le temps necessaire !!

[patricktoulon]

on a eu la meme idée

regarde ca je l'ai fait que dans un sens mais on peu le faire dans l'autre aussi
je n'est pas testé mais si je ne me suis pas trompé dans la syntaxe ca doit être ca

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
 
Sub met_des_ok_partout()
Dim tablos1 As Variant, tablos2 As Variant, tablos2OK() As Variant, tablos1OK As Variant
tablos1 = Range("a1:&" & S1.UsedRange.Rows)
tablos2 = Range("a1:&" & S2.UsedRange.Rows)
For Each elem In tablos2
If tablos2(elem) = tablos1(elem) Then
ReDim Preserve tablos2OK(1 To elem)
tablos2OK(elem) = "ok"
Else
tablos2OK(elem) = "ko"
End If
Next
S2.Range("b1:b" & UBound(tablos2OK)) = tablos2OK
'et on peut faire l'inverse
'dis moi que ca n'est pas plus rapide
End Sub

edit :je viens de corriger j'avais inverser tabos2ok avec tabos1ok
purré t'a raison je travaille trop
ce qui m'intéresse le plus c'est le double sens de comparaison je vais essayer d'approfondir avec les variables tablos
au plaisir

et je dirais meme que l'on peut aller encore plus vite

remplacer la boucle for par une boucle find qui est certainement plus rapide

au plaisir

re

essaie ca
le principe on met tout a "KO"
on boucle sur le tablo de la sheet2 et on compare avec la fonction "find "sur le sheets1
en fait tu le fait plus qu'une fois

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub truc()
Dim  tablos2 As Variant
Set s1 = Sheets(1)
Set s2 = Sheets(2)
tablos2 = s2.Range("a1:a" & s2.Range("a" & Rows.Count).End(xlUp).Row)
s1.Range("b1:b" & s1.Range("a" & Rows.Count).End(xlUp).Row) = "KO"
For Each elem2 In tablos2
 Set c = s1.Range("a1:a" & s1.Range("a" & Rows.Count).End(xlUp).Row).Find(elem2, LookIn:=xlValues)
    If Not c Is Nothing Then c.Offset(0, 1) = "OK"
Next
End Sub

au plaisir

ouais je suis vraiment fatigué

[Oliv-]

Bonjour,
Patrick désolé mais tes codes ne marchent pas ou très lentement.

Voici mon code Avec l'usage de dictionnaire optimisé :

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
Sub DictionnaireV2()
'19 SECONDS
    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
 
    Dim TabloS1 As Variant
    Dim TabloS2 As Variant
 
    TabloS1 = Range(s1.Range("A1"), s1.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1))
    TabloS2 = Range(S2.Range("A1"), S2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1))
 
    For i = 1 To UBound(TabloS1, 1)
        If Not mondico.Exists(TabloS1(i, 1)) Then mondico.Add TabloS1(i, 1), TabloS1(i, 1)
    Next i
 
    For i = 1 To UBound(TabloS2, 1)
        If mondico.Exists(TabloS2(i, 1)) Then
            mondicoCommun.Add TabloS2(i, 1), TabloS2(i, 1)
            TabloS2(i, 2) = "OK"
        Else
            TabloS2(i, 2) = "ko"
        End If
    Next i
 
    For i = 1 To UBound(TabloS1, 1)
        If mondicoCommun.Exists(TabloS1(i, 1)) Then
            TabloS1(i, 2) = "OK"
        Else
            TabloS1(i, 2) = "ko"
        End If
    Next i
 
Debug.Print Timer - T
Debug.Print mondico.Count
Debug.Print mondicoCommun.Count
    Application.StatusBar = mondicoCommun.Count
    Application.ScreenUpdating = False
    s1.Range("A1:b" & UBound(TabloS1)) = TabloS1
 
    S2.Range("A1:b" & UBound(TabloS2)) = TabloS2
    Application.ScreenUpdating = True
Debug.Print Timer - T
    MsgBox Timer - T
    '  temp = mondico.Items
    '  Call tri(temp, LBound(temp), UBound(temp))
    '  For i = LBound(temp) To UBound(temp): MsgBox temp(i): Next
End Sub

J'ai ouvert un nouveau post pour le pb d'effet de bord ADODB

et voici le code avec les filtres réciproques évoqué dans mon précédent message

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
Sub ssFiltre_reciproque()
' 37'
' Filtre_surSql Macro
'
    Dim T
    Dim s1
    Dim S2
 
    T = Timer
    Application.ScreenUpdating = False
 
    Set s1 = Sheets(1)
    Set S2 = Sheets(2)
 
    Dim ResultatSQL As Range
    Set FiltreS1 = Range(s1.Range("A1"), s1.Cells(Rows.Count, 1).End(xlUp))
    Set FiltreS2 = Range(S2.Range("A1"), S2.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
 
            If S.Name = s1.Name Then
                .UsedRange.Range("A1", Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                                                                      FiltreS2, Unique:=False
            Else
                .UsedRange.Range("A1", Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                                                                      FiltreS1, Unique:=False
 
            End If
            With .Range("B2", Cells(Rows.Count, 2).End(xlUp)).SpecialCells(xlCellTypeVisible)
                .Value = "OK"
                .Font.Color = vbGreen
            End With
            On Error Resume Next
            .ShowAllData
        End With
 
    Next S
 
    Application.ScreenUpdating = True
Debug.Print Timer - T
    MsgBox Timer - T
End Sub

[patricktoulon]

bonjour oliv

ca implique que les items doivent etre identique au niveau de l'index

et por remedier a ca tu fait simplement la boucle en inversant le dico1 et dico2
a mon avis il doit y avoir un moyen de ne faire qu'une seule boucle

au plaisir

[Oliv-]

Patrick,
Je crois que je n'ai pas été clair sur la finalité.

Je souhaite pour chaque liste connaitre les références communes dans l'autre! ces listes étant dans un ordre quelconque.

Feuil1
Siren | Resultat
1 | ok
9 | ko
3 | ok


Feuil2
Siren | Resultat
5 | ko
1 | ok
3 | ok
8 | ko

Cela me permettra ensuite de traiter les différences par ajout ou suppression....

[patricktoulon]

bonjour oliv+-

ok
il me semblais que plus haut tu disais vouloir determiner les communs pour avoir les autre ce que je trouvait inutile a mon gout

mais bon au cas ou ca t'interesse regarde ca:
2 boucle et c'est tout
la feuille 2 est rectifié par rapport a la feuille 1 directement teste la performance

j'ai utiliser simplement un 3eme tableau pour ca

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
 
Sub truc()
    Dim tablos2, tablo_a_rajouter, r As Long, e As Long, i As Long, derlig As Long, derlig2 As Long, T, presence As Boolean
    T = Timer
    Set s1 = Sheets(1): Set s2 = Sheets(2)
    If s1.Cells(Rows.Count, 1).End(xlUp).Row + 1 > s2.Cells(Rows.Count, 1).End(xlUp).Row + 1 Then
        derlig = s1.Cells(Rows.Count, 1).End(xlUp).Row + 1
    Else
        derlig = s2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    End If
    derlig2 = s2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'tablo 1 et 2 prennent la limite de la derniere ligne de la plage concernée
    tablos2 = Range(s2.Range("A1"), s2.Range("A" & derlig))
    TabloS1 = Range(s1.Range("A1"), s1.Range("A" & derlig))
    'tablo_a_rajouter commence a la derniere ligne renseigne de s1 et fini a la derniere ligne
    tablo_a_rajouter = Range(s2.Range("b" & derlig2), s2.Range("b" & Rows.Count))    'cette colonne est vide donc les item seront vides on les rempliera plus tard
    r = 0
    For e = 1 To UBound(TabloS1, 1)
        DoEvents
        presence = False
        For i = 1 To UBound(tablos2, 1)
            If tablos2(i, 1) = TabloS1(e, 1) Then
                presence = True
                Exit For
            End If
        Next
        'si c'est false on ajoute l'item au tableau"tableau_a_ajouter"
        If presence = fase Then
            r = r + 1
            tablo_a_rajouter(r, 1) = TabloS1(e, 1)
        End If
    Next
    'on ajoute le tableau_a_rajouter a la suite dans le s2
    s2.Range("a" & derlig2 & ":a" & derlig2 + r) = tablo_a_rajouter
    MsgBox Timer - T
End Sub

j'ai tester sur 2000 lignes
qu'en pense tu ??

[Oliv-]

c'est la cata.!
Sur mon vieux pc mon DictionnaireV2 met 7 sec pour comparer 20000 x 4000 lignes. et doit donner 2000 en communs (voir création_sources()).

ton dernier code met 159 sec et le resultat est faux.(edit :parce que pas dans B:B de chaque source )

Laisse tomber je suis assez satisfait de mon code.

Merci pour tes propositions

[patricktoulon]

re
bonjour oliv+-

j'ai du mal a croire que le dernier code te donne un résultat faux

je l'ai moi meme essayé sur 2000 lignes et tout les absents d'un coté sont ressortis j'ai controlé 3 fois

mathématiquement c'est impossible ou alors une variable est commune a un autre code

ensuite il me parait invraisemblable que 4 boucle for
2sur les tableau (seulement ce qu'utilise le mien)et 2 sur les dictionnaires soient plus rapide que 2boucles imbriquées sur 2 tableaux on doit pas avoir les memes librairies ce qui est possible je l'ai vu tres souvent avec la comparaison 2003 et 2007 xp ou seven
j'ai dailleur les deux version qui cohabitent sur seven et effectivement selon la version certaines de mes macros n'ont pas le meme comportement

ensuite le mien en une fois il te rajoute les non communs hors ton code s'arrete au tri finalement

mais 159 secondes je suis surpris tu a quoi comme becanne

avec ta méthode chez moi le temps est multiplié par a peu près 2 ce qui est logique finalement
mais bon si ca te conviens

[Oliv-]

Patrick,
Voici un fichier pour tester.
Voici mes temps au boulot (Xp pro/office 2007):
Dicov2 = 1,96 sec
Truc = 54,73 sec
FiltresReciproques = 47,81 sec.

[Oliv-]

tototiti2008, oui ta solution ADODB fait cela très vite mais en dégradant les performances, la solution serait apparemment de copier les 2 feuilles vers un nouveau classeur avant ou alors de faire un select into dans SQL.

il y avait aussi le pb de reclassement des colonnes par ordre ?