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
voici mon code
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
dans un autre module
en fait je voudrais une critique de celui-ci et des pistes d'amélioration de la vitesse d'exécution.
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
Partager