[VBA-E+SQL] Message d'erreur et excel qui plante

Version imprimable

Bonjour à tous ,

j'ai fais une procédure afin de compter le nombre de fois qu'est présent chaque numéro de référence dans une autre feuille et que ce nombre de fois soit mis sur la même ligne que cette référence d'où ce code :

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
65
Private Sub RemplissageSynthèse4()
 
Application.ScreenUpdating = False
 
ThisWorkbook.Worksheets("SYNTHESE").Activate
 
Dim CodeTemporaire As String
'Déclaration de la connexion
Dim Conn As ADODB.Connection
 
'Déclaration du Recordset
Dim rsT As ADODB.Recordset
 
 
Dim Fichier As String, Direction As String, rSQL As String
 
Direction = ThisWorkbook.Path
Fichier = "OUTIL HD TRAVAIL.xls"
 
    'Instanciation de la connexion
    Set Conn = New ADODB.Connection
 
    'Paramétrage & Ouverture
    With Conn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=" & Direction & "\" & Fichier & _
    ";Extended Properties=Excel 8.0;"
    .Open
    End With
 
    'Instanciation du Recordset
    Set rsT = New ADODB.Recordset
 
    rsT.ActiveConnection = Conn
 
    i = 2
 
    Do While Not IsEmpty(Cells(i, 1))
 
        CodeTemporaire = Cells(i, 1)
 
        'Insertion de la requête SQL dans rSQL
        rSQL = "SELECT Count([CDCOURTI]) FROM [HD$] WHERE [CDCOURTI]='" & CodeTemporaire & "'"
 
        With rsT
        .ActiveConnection = Conn
        .Open rSQL, Conn
        End With
 
 
        'Copie des données
        Cells(i, 9).CopyFromRecordset rsT
        rsT.Close
        rSQL = ""
        CodeTemporaire = ""
 
        i = i + 1
 
    Loop
 
 
    Conn.Close
 
 Application.ScreenUpdating = True
End Sub

Le résultat renvoyé est bon seulement au bout d'une vingtaine de seconde excel m'affiche que "la liaison avec la feuille est perdue" ainsi que "Memoire insufisante pour continuer" (j'ai 512 mo et tout n'est pas utilisé lors de l'execution dixit le gestionnaire des taches)
Quelqu'un a t-il une idée de solution au problème ???

08/02/2006, 15h56
Bigyork
En général le message "Mémoire insuffisante" apparait quand par exemple tu fais plusieurs connection sur une base sans fermer la précédente ou quand tu es dans une boucle sans fin, ...

as-tu réellement besoin de .ActiveConnection = Conn dans
Code:

1 2 3 4 With rsT .ActiveConnection = Conn .Open rSQL, Conn End With
Puisque à priori tu initialises cette propriété avant ta boucle ?
08/02/2006, 16h33
Deejoh

j'ai essayé en lemettant hors de la boucle et sa pose le même problème :-/
10/02/2006, 17h29
SilkyRoad
bonsoir

as tu essayé
Code:

1 2 3 4 ... rsT.Close Set rsT = Nothing ...
bon wee kend
michel

salut Deejoh

Test ceci

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
Private Sub RemplissageSynthèse4() 
 
Application.ScreenUpdating = False 
 
ThisWorkbook.Worksheets("SYNTHESE").Activate 
 
Dim CodeTemporaire As String 
'Déclaration de la connexion 
Dim Conn As ADODB.Connection 
 
'Déclaration du Recordset 
Dim rsT As ADODB.Recordset 
 
 
Dim Fichier As String, Direction As String, rSQL As String 
 
Direction = ThisWorkbook.Path 
Fichier = "OUTIL HD TRAVAIL.xls" 
 
    'Instanciation de la connexion 
    Set Conn = New ADODB.Connection 
 
    'Paramétrage & Ouverture 
    With Conn 
    .Provider = "Microsoft.Jet.OLEDB.4.0" 
    .ConnectionString = "Data Source=" & Direction & "\" & Fichier & _ 
    ";Extended Properties=Excel 8.0;" 
    .Open 
    End With 
 
    'Instanciation du Recordset 
    Set rsT = New ADODB.Recordset 
    rsT.ActiveConnection = Conn 
 
    i = 2 
 
    Do While Not IsEmpty(Cells(i, 1)) 
 
        CodeTemporaire = Cells(i, 1) 
 
        'Insertion de la requête SQL dans rSQL 
        rSQL = "SELECT Count([CDCOURTI]) FROM [HD$] WHERE [CDCOURTI]='" & CodeTemporaire & "'" 
 
        With rsT 
           .source = rSql
           .open        
        End With         
 
        'Copie des données 
        Cells(i, 9).CopyFromRecordset rsT 
        rsT.Close 
        rSQL = "" 
        CodeTemporaire = "" 
        i = i + 1 
    Loop     
    Conn.Close 
Set rsT = nothing
Set Conn = Nothing
 
 Application.ScreenUpdating = True 
End Sub

16/02/2006, 16h28
Deejoh

ça marche GENIAL merci beaucoup :)