[Toutes versions] Recordset ADODB dégrade les performances VBA !

Bonjour,
Lorsque j'utilise un recordset ADODB les performances de traitement VBA à la suite sont très nettement dégradées .

La macro effet_bord passe de 1 seconde à 26 secondes je suis obligé de fermer Excel pour retrouver des performances normales.

Voici le test :

Code:

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
Sub Lancer_Procedure_test()
    effet_bord
    Test_effet_bord_ado
    effet_bord
End Sub
Sub Test_effet_bord_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
    Application.ScreenUpdating = False
 
    If ActiveWorkbook.Path = "" Then
        MsgBox "vous devez enregistrer ce fichier!"
        Exit Sub
    End If
    Set s1 = Worksheets("Feuil1")
    Set S2 = Worksheets("Feuil2")
    Set SR = Worksheets("Feuil3")    'Worksheets("SQL_COMMUNS")
 
    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, 0, 3
    rs.Close
    cn.Close
    Set cn = Nothing
    Set rs = Nothing
 
    Application.ScreenUpdating = True
    MsgBox prompt:="Terminé ! : " + CStr(Time - t0)
End Sub
 
 
Sub effet_bord()
    Dim t0 As Double, i
    t0 = Time
 
    Application.ScreenUpdating = False
 
    Set s1 = Worksheets("Feuil1")
    For i = 2 To s1.Cells(Rows.Count, 1).End(xlUp).Row
        s1.Cells(i, 2).Value = "OK"
    Next i
 
    Application.ScreenUpdating = True
    MsgBox prompt:="Terminé ! : " + CStr(Time - t0)
End Sub

pour créer le fichier test (à enregistrer)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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