Erreur d'exécution '-2147417856 (80010100)': La méthode 'CopyFromRecordset' de l'objet 'Range' a échoué

**cyrgod** · 19/04/2010, 16h40

Voici le message qui s'affiche quand j'exécute la ligne de code suivante :

Code :

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

1
2
3
4
5
6
        'Definition des colonnes
        For iCols = 0 To Rs.Fields.Count - 1
            oSheet.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name
        Next iCols
        'Remplissage des colonnes avec les données
        oSheet.Range("A2").CopyFromRecordset Rs

Erreur d'exécution '-2147417856 (80010100)':
La méthode 'CopyFromRecordset' de l'objet 'Range' a échoué

J'ai l'impression que de temps en temps, il perd la trace de l'objet pendant un court instant car quand je passe en mode débogage et que je relance manuellemement le programme, celui-ci passe sans problème et se déroule très bien ...

Avez-vous uen explication à ce message car je n'arrive pas à trouver de solution pour que cela ne se produise pas de manière intempestive ?

**argyronet** · 19/04/2010, 19h53

Bonjour (non facultatif sur le forum)

Quels types de données sont copiés dans la feuille de calcul Excel ?
N'y a-t-il que des numériques, textes ou des dates ou éventuellement d'autres types de champ ?

Argy

**cyrgod** · 20/04/2010, 10h06

Bonjour,

En effet, c'est non faculatatif mais quand on se promène sur le forum depuis un moment, on pense ensuite qu'on a déjà dit bonjour à tout le monde

Les données exportées sont de type texte (longueur variable) ou numérique (Réel double) exclusivement.

Meric de m'aider.

**argyronet** · 20/04/2010, 10h24

Bien...
Hummm, la notion de "longueur variable" peut elle dépasser 255 caractères ?
Puisse t-il y avoir des NULL dans tes champs ?
Ce peut-être une des causes mais dans ton cas, il faut procéder par élimination.

Argy

**cyrgod** · 20/04/2010, 11h45

Les données typées en texte n'excèdent pas 50 caractères. Par contre elles peuvent prendre la valeur Null en effet. De plus la requête peut ne rien retourner.

**argyronet** · 20/04/2010, 12h15

Humm, regarde du coté des NULL et substitue tes valeurs avec la fonction Nz().
Par exemple dans une requête :

Code :

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

MonChampXL:Nz(MonChampAccess; "")

Est-ce que c'est mieux ?

Argy

**cyrgod** · 20/04/2010, 14h14

Et bien un grand merci

car sur les quelques 500 appels de ce code que j'ai effectués, cela s'est déroulé sans aucun arrêt intempestif. C'est un peu plus long en traitement mais au moins je n'ai plus de blocage et c'est là l'essentiel

**argyronet** · 20/04/2010, 16h06

Ravi de l'apprendre...

Envoyé par cyrgod

C'est un peu plus long en traitement mais au moins je n'ai plus de blocage et c'est là l'essentiel

Ca ne peut pas s'optimiser ?

Argy

**cyrgod** · 23/04/2010, 16h35

Mauvaise nouvelle, ça a recommencé. Le Nz n'a en fait pas solutionné mon problème.
Je vais donc essayer de temporiser le traitement.

Code Temporisation :

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

1
2
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 sleep 1000

Sinon j'ai testé différentes choses pour optimiser le temps de traitement mais ça ne semble pas changer grand chose.
oExcel.ScreenUpdating = False
oExcel.Calculation = xlCalculationManual

**Jean-Philippe André** · 23/04/2010, 19h17

salut,
peut-on voir le coeur du probleme:
- le code SQL de ta requete
- le reste du code VBA en amont de ce qui semble poser probleme

**cyrgod** · 07/05/2010, 14h46

Bonjour,

Désolé pour mon temps de réponse et merci de m'aider sur ce point où je n'arrive pas à apporter de solution. J'ai essayé le Nz et j'ai essayé aussi de recommencer en cas d'erreur sans succès.

Le SQL de la requête est celui-ci :

Code REQUETE :

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

1
2
3
SELECT Nz(E.ED,"") AS ED, Nz(E.LOC,"") AS LOC, Nz(E.CIE,"") AS CIE, Nz(E.PAYS,"") AS PAYS, Nz(E.MONNAIE,"") AS MONNAIE, Nz(E.BANQUE,"") AS BANQUE, Nz(E.GUICHET,"") AS GUICHET, IIf(Left(Nz(E.COMPTE,""),2)="ZT",Nz(E.COMPTE,""),"ZT" & Nz(E.COMPTE,"")) AS COMPTE, Nz(E.IDENTIFIANT,"") AS IDENTIFIANT, Nz(E.ORIGINE,"") AS ORIGINE, Nz(E.DEBIT,0) AS DEBIT, Nz(E.CREDIT,0) AS CREDIT, Nz(E.DEBIT,0)-Nz(E.CREDIT,0) AS SOLDE, Nz(CLE_RAPPRO.FLAG,"") AS EMARGEMENT, "" AS OBSERVATIONS, "" AS ECART, "" AS [ECART POSITIF/NEGATIF], IIf([AV] & [C] & [D] & [F] & [O] & [V]="","N/D",IIf([AV] & [C] & [D] & [F] & [O] & [V] Not In ('AV','C','D','F','O','V'),"DBL: " & [AV] & [C] & [D] & [F] & [O] & [V],[AV] & [C] & [D] & [F] & [O] & [V] & Left(E.ORIGINE,1))) AS [TYPE DE SUSPENS], "" AS REGULARISATION, Abs(Nz(E.DEBIT,0)-Nz(E.CREDIT,0)) AS [VALEUR ABSOLUE], Left(Nz(E.DtValeur,""),4) AS ANNEE, Nz(E.CODE_OPERATION,"") AS CODE_OPERATION, Nz(E.LIB_OPERATION,"") AS LIB_OPERATION, Mid(Nz(E.DtValeur,""),3,2) & Mid(Nz(E.DtValeur,""),6,2) & Mid(Nz(E.DtValeur,""),9,2) AS [DATE VALEUR], Mid(Nz(E.DtOperation,""),3,2) & Mid(Nz(E.DtOperation,""),6,2) & Mid(Nz(E.DtOperation,""),9,2) AS [DATE OPERATION], Mid(Nz(E.DtCompta,""),3,2) & Mid(Nz(E.DtCompta,""),6,2) & Mid(Nz(E.DtCompta,""),9,2) AS [DATE COMPTABLE], Nz(E.ECRITURE,"") AS ECRITURE, Nz(E.LIGNE,"") AS LIGNE, Nz(E.ARRANGEMENT,"") AS ARRANGEMENT, Nz(E.EXON,"") AS EXON, IIf((E.LIB_OPERATION Like "*AC*" And E.LIB_OPERATION Not Like "*[a-zA-Z;/]AC*") Or E.LIB_OPERATION Like "*AC[0-9]*" Or E.LIB_OPERATION Like "*RACH*" Or (E.LIB_OPERATION Like "*AT*" And E.LIB_OPERATION Not Like "*[a-zA-Z;/]AT*") Or E.LIB_OPERATION Like "*AT[0-9]*" Or E.LIB_OPERATION Like "*VT*" Or E.LIB_OPERATION Like "*VC*" Or E.LIB_OPERATION Like "*E01*" Or E.LIB_OPERATION Like "*AHM*" Or E.LIB_OPERATION Like "*VENTE*" Or E.LIB_OPERATION Like "*R*SICAV*" Or E.LIB_OPERATION Like "*S*SICAV*" Or E.LIB_OPERATION Like "*SOUS[c;C; ]*" Or E.LIB_OPERATION Like "*SOU *" Or E.LIB_OPERATION Like "*GRE A GRE*" Or E.LIB_OPERATION Like "*NEGO*" Or E.LIB_OPERATION Like "*COMPTANT*" Or (E.LIB_OPERATION Like "*CPT*" And E.LIB_OPERATION Like "*CPT[a-zA-Z]*") Or E.LIB_OPERATION Like "*RETRAIT*" And E.LIB_OPERATION Not Like "*FRAIS*" And E.LIB_OPERATION Not Like "*VIR*","AV","") AS AV, IIf((E.LIB_OPERATION Like "*ERE*" And E.LIB_OPERATION Not Like "*[a-zA-Z0-9]ERE*") Or E.LIB_OPERATION Like "*I01*" Or E.LIB_OPERATION Like "*I02*" Or E.LIB_OPERATION Like "*I04*" Or E.LIB_OPERATION Like "*I05*" Or E.LIB_OPERATION Like "*[a;e;A;E]PH*" Or E.LIB_OPERATION Like "*REVENU*" Or E.LIB_OPERATION Like "*SOULTE*" Or E.LIB_OPERATION Like "*COUPON*" Or E.LIB_OPERATION Like "*CPS*" Or E.LIB_OPERATION Like "*CPON*" Or E.LIB_OPERATION Like "*COUP *" Or E.LIB_OPERATION Like "*DIVIDENDE*" And E.LIB_OPERATION Not Like "*OST*","C","") AS C, IIf((E.LIB_OPERATION Like "*COMM*" Or E.LIB_OPERATION Like "*COM *" Or E.LIB_OPERATION Like "*OP*CASH*" Or E.LIB_OPERATION Like "*CDT*" Or (E.LIB_OPERATION Like "*FRAIS*" And E.LIB_OPERATION Not Like "*FRAIS DE*") Or (E.LIB_OPERATION Like "*FRS*" And E.LIB_OPERATION Not Like "*GEST*") Or (E.LIB_OPERATION Like "*DG*" And E.LIB_OPERATION Not Like "*[a-c;e-zA-C;E-Z]DG*" And E.LIB_OPERATION Not Like "*DG[a-zA-Z]*") Or (E.LIB_OPERATION Like "*GARDE*" And E.LIB_OPERATION Not Like "*[a-zA-Z]GARDE*" And E.LIB_OPERATION Not Like "*GARDE[a-zA-Z]*") Or E.LIB_OPERATION Like "*RISTOU*" Or E.LIB_OPERATION Like "*INTERET*" Or E.LIB_OPERATION Like "*FACTU*" Or E.LIB_OPERATION Like "*AGIO*" Or E.LIB_OPERATION Like "*REFERE*") And E.LIB_OPERATION Not Like "*[a-zA-Z]COM*" And E.LIB_OPERATION Not Like "*COMM[a-h;j-zA-H;J-Z]*" And E.LIB_OPERATION Not Like "*OD[M;T]*" And E.LIB_OPERATION Not Like "*VIR*","D","") AS D, IIf(E.LIB_OPERATION Like "*FDG*" Or E.LIB_OPERATION Like "*FHG*" Or E.LIB_OPERATION Like "*FRAIS*GEST*" Or E.LIB_OPERATION Like "*FRAIS DE*" Or E.LIB_OPERATION Like "*FGE*" Or E.LIB_OPERATION Like "*FG *" Or E.LIB_OPERATION Like "*FRS*GEST*" And E.LIB_OPERATION Not Like "*MANDAT*","F","") AS F, IIf((E.LIB_OPERATION Like "*CHM*" Or E.LIB_OPERATION Like "*RTC*" Or E.LIB_OPERATION Like "*RCT*" Or E.LIB_OPERATION Like "*RO[0-9]*" Or E.LIB_OPERATION Like "* RO/*" Or (E.LIB_OPERATION Like "*OST*" And E.LIB_OPERATION Not Like "*OST[a-zA-Z]*" And E.LIB_OPERATION Not Like "*[a-zA-Z]OST*") Or E.LIB_OPERATION Like "*OPA*" Or E.LIB_OPERATION Like "* DA[0-9_]*" Or E.LIB_OPERATION Like "* DS[0-9_]*" Or E.LIB_OPERATION Like "*PRIM*DIV*") And E.LIB_OPERATION Not Like "*VENTE*","O","") AS O, IIf(E.LIB_OPERATION Like "*OD[M;T]*" Or E.LIB_OPERATION Like "*TDF*" Or E.LIB_OPERATION Like "*ADV*" Or E.LIB_OPERATION Like "*VDC*" Or E.LIB_OPERATION Like "*INVEST*" Or E.LIB_OPERATION Like "*DESINV*" Or E.LIB_OPERATION Like "*I/D*" Or (E.LIB_OPERATION Like "*VIR*" And E.LIB_OPERATION Not Like "*[a-zA-Z]VIR*" And E.LIB_OPERATION Not Like "*VIR[a-d;f-s;u-zA-D;F-S;U-Z]*") Or E.LIB_OPERATION Like "*VRT*" Or E.LIB_OPERATION Like "*FPJ*" Or E.LIB_OPERATION Like "*PENSION*" Or E.LIB_OPERATION Like "*RECU*" Or E.LIB_OPERATION Like "*TRESO*" And E.LIB_OPERATION Not Like "*ERE/*" And E.LIB_OPERATION Not Like "*EREU/*" And E.LIB_OPERATION Not Like "*FRAIS*" And E.LIB_OPERATION Not Like "*FDG*" And E.LIB_OPERATION Not Like "*FG*","V","") AS V, S.ID_NOSTRO
FROM (T_EXTRCB AS E INNER JOIN T_SUSPENS AS S ON E.ID_EXTRCB = S.ID_EXTRCB) LEFT JOIN RCB_EMARGEMENT_SUSPENS AS CLE_RAPPRO ON E.ID_EXTRCB = CLE_RAPPRO.ID_EXTRCB
WHERE (((S.ID_NOSTRO)=[@ID_NOSTRO]) AND ((S.ID_SUSPENS)>=[@LimiteMin] And (S.ID_SUSPENS)<[@LimiteMax]));

et le code de la fonction où j'ai un blocage parfois est celui-ci :

Code FONCTION :

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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
Function ExportSuspensNOSTRO(sUser As String, sHorodatage As String) As Boolean
 
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'EXPORT DES ANALYSES EFFECTUEES
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
 
Dim URL As String
Dim sDir As String
Dim Qdf As DAO.QueryDef
Dim Rs As DAO.Recordset
Dim SQL As String
Dim oExcel As Excel.Application
Dim oWkb As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim i As Long
Dim j As Integer
Dim iMax As Long
Dim jMax As Integer
Dim iLimInf As Long
Dim iLimSup As Long
Dim sCdPtf As String
Dim sCdNOSTRO As String
Dim iCols As Integer
Dim sCieNostro As String
Dim bRecommence As Integer
 
ExportSuspensNOSTRO = False
 
'----------------------------------------------------
'EXPORT DES LIGNES NON EMARGEES PAR CODE NOSTRO
'----------------------------------------------------
 
'Definition du nombre de fichiers nécessaires
If IsNull(DMax("ID_NOSTRO", "T_NOSTRO_SUSPENS_" & sUser)) Then Exit Function
jMax = DMax("ID_NOSTRO", "T_NOSTRO_SUSPENS_" & sUser)
 
For j = 1 To jMax
 
    'Definition du sous-répertoire Compagnie d'export
    If DLookup("CIE", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j) <> sCieNostro Then
        'Création du répartoire principal
        sDir = DLookup("URL", "P_CHEMINS_" & sUser, "Dossier='RCB_OUTPUT'")
        sDir = SlashURL(sDir) & "AUTO"
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
        sDir = SlashURL(sDir) & sHorodatage
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
        sCieNostro = DLookup("CIE", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
        sDir = SlashURL(sDir) & sCieNostro
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
    End If
 
    'Definition du nombre d'onglets nécessaires
    SQL = Replace(CurrentDb.QueryDefs("RCB_SUSPENS_NOSTRO_" & sUser).SQL, "[@ID_NOSTRO]", j)
    Set Qdf = CurrentDb.CreateQueryDef("PIPO_" & sUser, SQL)
    iLimInf = Nz(DMin("ID_SUSPENS", Qdf.Name), 0)
    iLimSup = Nz(DMax("ID_SUSPENS", Qdf.Name), 0)
    iMax = Int((iLimSup - iLimInf + 1) / iLigMaxExcel) + 1 + 1
    DoCmd.DeleteObject acQuery, Qdf.Name
    Set Qdf = Nothing
 
    'Definition de l'URL du fichier d'export
    sCdPtf = DLookup("PTF", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
    sCdPtf = Replace(sCdPtf, "/", "~")
    sCdPtf = Replace(sCdPtf, "\", "~")
    sCdNOSTRO = DLookup("NOSTRO", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
    URL = SlashURL(sDir) & sCieNostro & " - " & sCdPtf & " - " & sCdNOSTRO & ".xls"
 
    'Instanciation Excel
    Set oExcel = New Excel.Application
    'Creation d'un classeur avec le nombre de feuilles nécessaires
    oExcel.SheetsInNewWorkbook = iMax
    Set oWkb = oExcel.Workbooks.Add
 
 
    'EXPORT DES SUSPENS POUR LE CODE PTF ET LE CODE NOSTRO de jMax
    '==================================================================
    For i = 1 To iMax - 1
 
        'Creation des objets
        Set oSheet = oWkb.Worksheets(i)
        oSheet.Activate
        oSheet.Name = "SUSPENS " & i
        SQL = Replace(CurrentDb.QueryDefs("RCB_SUSPENS_" & sUser).SQL, "[@ID_NOSTRO]", j)
        SQL = Replace(SQL, "[@limiteMin]", (i - 1) * iLigMaxExcel + iLimInf)
        SQL = Replace(SQL, "[@limiteMax]", i * iLigMaxExcel + iLimInf)
        Set Qdf = CurrentDb.CreateQueryDef("PIPO_" & sUser, SQL)
        Set Rs = CurrentDb.OpenRecordset(Qdf.Name)
        If Not Rs.BOF Then Rs.MoveFirst
 
        'Definition des colonnes
        For iCols = 0 To Rs.Fields.Count - 1
            oSheet.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name
        Next iCols
        'Remplissage des colonnes avec les données
        'Si plantage pour raison inconnue, on recommence le copyfromrecordset
        bRecommence = False
Recommence:
        If bRecommence = True Then GoTo 0
        On Error GoTo Recommence
        bRecommence = True
        oSheet.Range("A2").CopyFromRecordset Rs
 
        'Mise en place de valeurs de validation
        With oSheet.Range("R2:R" & Rs.RecordCount + 1).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="" & sListeTypageValide
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "Typages des suspens autorisés"
            .ErrorTitle = "Typage de suspens invalide"
            .InputMessage = "Merci de saisir un typage de suspens valide"
            .ErrorMessage = "Le typage de suspens saisi est invalide. Merci de saisir un typage valide dans la liste."
            .ShowInput = True
            .ShowError = True
        End With
 
        'Mise en forme de la feuille
        oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 256)).Font.Bold = True
        oSheet.Rows("1:1").AutoFilter
        oSheet.Cells.Font.Size = 8
        oSheet.Range("K:M").Style = "Comma"
        oSheet.Range("T:T").Style = "Comma"
        oSheet.Cells.EntireColumn.AutoFit
 
        'Purge des colonnes non désirées mais nécessaires dans la requête
        oSheet.Range(oSheet.Cells(1, 31), oSheet.Cells(1, 37)).EntireColumn.Delete
 
        'Purge des objets
        DoCmd.DeleteObject acQuery, "PIPO_" & sUser
        Rs.Close
        Set Rs = Nothing
        Set Qdf = Nothing
 
    Next i
    '==================================================================
 
 
    'EXPORT DE LA VERIFICATION DES SOLDES
    '==================================================================
    Set oSheet = oWkb.Worksheets(iMax)
    oSheet.Activate
    oSheet.Name = "VERIFICATION DES SOLDES"
    SQL = Replace(CurrentDb.QueryDefs("RCB_VERIFICATION_DES_SOLDES_" & sUser).SQL, "[@ID_NOSTRO]", j)
    Set Qdf = CurrentDb.CreateQueryDef("PIPO_" & sUser, SQL)
    Set Rs = CurrentDb.OpenRecordset(Qdf.Name)
    If Not Rs.BOF Then Rs.MoveFirst
 
    'Definition des colonnes
    For iCols = 0 To Rs.Fields.Count - 1
        oSheet.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name
    Next iCols
    'Remplissage des colonnes avec les données
    oSheet.Range("A2").CopyFromRecordset Rs
 
    'Complement d'information
    oSheet.Range("J1").Value = "SOLDE_RCB"
    oSheet.Range("K1").Value = "ECART_SUSPENS"
    SQL = ""
    For i = 1 To iMax - 1
        Set oSheet = oWkb.Worksheets(i)
        oSheet.Rows("1:1").AutoFilter Field:=10, Criteria1:="BANQUE"
        oSheet.Range(oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)), oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)).End(xlToRight)).Font.ColorIndex = 3
        oSheet.Rows("1:1").Font.ColorIndex = 0
        oSheet.Rows("1:1").AutoFilter
        oSheet.Rows("1:1").AutoFilter
 
        SQL = SQL + "+SUM((RC[-7]='SUSPENS " & i & "'!RC[-4]:R[65534]C[-4])*(RC[-6]='SUSPENS " & i & "'!RC[-3]:R[65534]C[-3])*(RC[-5]='SUSPENS " & i & "'!RC[-2]:R[65534]C[-2])*'SUSPENS " & i & "'!RC[3]:R[65534]C[3])"
    Next i
 
    Set oSheet = oWkb.Worksheets(iMax)
 
    iMax = oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)).Row + 1
 
    oSheet.Range(oSheet.Cells(2, 10), oSheet.Cells(iMax, 10)).FormulaArray = "=" & SQL
    oSheet.Range(oSheet.Cells(2, 11), oSheet.Cells(iMax, 11)).FormulaR1C1 = "=RC[-1]-RC[-3]-RC[-2]"
 
    'Mise en forme de la feuille
    oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 256)).Font.Bold = True
    oSheet.Rows("1:1").AutoFilter
    oSheet.Cells.Font.Size = 8
    For i = 2 To iMax
        oSheet.Range("G2:G" & i).Value = CDbl(oSheet.Range("G2:G" & i).Value)
        oSheet.Range("H2:H" & i).Value = CDbl(oSheet.Range("H2:H" & i).Value)
        oSheet.Range("I2:I" & i).Value = CDbl(oSheet.Range("I2:I" & i).Value)
    Next i
 
    oSheet.Range("G:K").Style = "Comma"
    oSheet.Cells.EntireColumn.AutoFit
 
    'Purge des objets
    DoCmd.DeleteObject acQuery, "PIPO_" & sUser
    Rs.Close
    Set Rs = Nothing
    Set Qdf = Nothing
    '==================================================================
 
 
    'If Dir(URL) <> "" Then Kill URL
    oWkb.SaveAs URL, xlWorkbookNormal
    oWkb.Close
    Set oWkb = Nothing
    Set oSheet = Nothing
    oExcel.Quit
    Set oExcel = Nothing
 
Next j
 
ExportSuspensNOSTRO = True
 
End Function

**argyronet** · 07/05/2010, 15h40

Woooa yaille yaille !!!

C'est de l'optimisation ce code...
T'aies-tu rendu compte que si jMax vaut 1000

tu instanciera 1000 fois Excel !!!
tu appelleras autant de fois 3 fonctions de domaine (lourde)
tu créeras et détruiras 1000 fois une requête pour avor 2 valeurs
...

Tu devrais à mon avis repenser fortement ce bloc qui, si comme tu le dis bloque, eh bien, c'est plus que normal...

Après, on pourra peut-être s'occuper sérieusement de ton Erreur d'exécution '-2147417856 (80010100)':

Argy

**cyrgod** · 07/05/2010, 15h48

En effet

Je vais tâcher de réduire certains appels. Merci de ces remarques car je suis autodidacte et il doit y avoir en effet mieux à faire.

Alors après un peu de travail :

Excel n'est plus qu'instancié une seule fois

Je ne fais plus de création/destruction de requêtes soit en modifiant le code SQL directement et en le remettant à l'origine lors du passage à la boucle suivante soit en passant mes critères directement dans les fonctions de domaine Dmin et Dmax pour récupérer mes bornes.

J'ai essayé de réduire le nombre d'appel à Dmin, Dmax ou DLookup mais sans pouvoir m'en affranchir. Si c'est lourd en temps de traitment, y a t'il un meilleur moyen de faire ?

Bilan : pas de blocage (en même temps c'était aléatoire) et un temps de traitement réduit de 10%.

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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
Function ExportSuspensNOSTRO(sUser As String, sHorodatage As String) As Boolean
 
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'EXPORT DES ANALYSES EFFECTUEES
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
 
Dim URL As String
Dim sDir As String
Dim Qdf As DAO.QueryDef
Dim Rs As DAO.Recordset
Dim SQL As String
Dim SQL_Generique As String
Dim oExcel As Excel.Application
Dim oWkb As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim iMax As Long
Dim jMax As Integer
Dim iLimInf As Long
Dim iLimSup As Long
Dim sCdPtf As String
Dim sCdNOSTRO As String
Dim iCols As Integer
Dim sCieNostro As String
Dim bRecommence As Integer
 
ExportSuspensNOSTRO = False
 
'----------------------------------------------------
'EXPORT DES LIGNES NON EMARGEES PAR CODE NOSTRO
'----------------------------------------------------
 
'Definition du nombre de fichiers nécessaires
If IsNull(DMax("ID_NOSTRO", "T_NOSTRO_SUSPENS_" & sUser)) Then Exit Function
jMax = DMax("ID_NOSTRO", "T_NOSTRO_SUSPENS_" & sUser)
 
'Instanciation Excel pour l'export des fichiers
Set oExcel = New Excel.Application
 
For j = 1 To jMax
 
    'Definition du sous-répertoire Compagnie d'export
    If j = 1 Or j = k Then
        'Création du répertoire principal
        sDir = DLookup("URL", "P_CHEMINS_" & sUser, "Dossier='RCB_OUTPUT'")
        sDir = SlashURL(sDir) & "AUTO"
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
        sDir = SlashURL(sDir) & sHorodatage
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
        sCieNostro = DLookup("CIE", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
        sDir = SlashURL(sDir) & sCieNostro
        If Dir(sDir, vbDirectory) = "" Then MkDir sDir
        'Recherche du prochain j portant une CIE différente de la CIE courante
        k = Nz(DMin("ID_NOSTRO", "T_NOSTRO_SUSPENS_" & sUser, "CIE<>'" & sCieNostro & "' And ID_NOSTRO>" & j), 0)
    End If
 
    'Definition du nombre d'onglets nécessaires
    iLimInf = Nz(DMin("ID_SUSPENS", "RCB_SUSPENS_NOSTRO_" & sUser, "[ID_NOSTRO] =" & j), 0)
    iLimSup = Nz(DMax("ID_SUSPENS", "RCB_SUSPENS_NOSTRO_" & sUser, "[ID_NOSTRO] =" & j), 0)
    iMax = Int((iLimSup - iLimInf + 1) / iLigMaxExcel) + 1 + 1
 
    'Definition de l'URL du fichier d'export
    sCdPtf = DLookup("PTF", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
    sCdPtf = Replace(sCdPtf, "/", "~")
    sCdPtf = Replace(sCdPtf, "\", "~")
    sCdNOSTRO = DLookup("NOSTRO", "T_NOSTRO_SUSPENS_" & sUser, "ID_NOSTRO=" & j)
    URL = SlashURL(sDir) & sCieNostro & " - " & sCdPtf & " - " & sCdNOSTRO & ".xls"
 
    'Creation d'un classeur avec le nombre de feuilles nécessaires
    oExcel.SheetsInNewWorkbook = iMax
    Set oWkb = oExcel.Workbooks.Add
 
    'EXPORT DES SUSPENS POUR LE CODE PTF ET LE CODE NOSTRO de jMax
    '==================================================================
 
    'Sauvegarde du SQL de la requête RCB_SUSPENS appelée lors des exports
    'car ce SQL sera modifé à chaque export pour limiter à 65000 lignes
    Set Qdf = CurrentDb.QueryDefs("RCB_SUSPENS_" & sUser)
    SQL_Generique = CurrentDb.QueryDefs("RCB_SUSPENS_" & sUser).SQL
 
    'Début de la boucle sur chaque onglet de 65000 lignes
    For i = 1 To iMax - 1
 
        'Creation des objets
        Set oSheet = oWkb.Worksheets(i)
        oSheet.Activate
        oSheet.Name = "SUSPENS " & i
 
        'Modification du SQL de notre requête générique
        SQL = Replace(Qdf.SQL, "[@ID_NOSTRO]", j)
        SQL = Replace(SQL, "[@limiteMin]", iLimInf + (i - 1) * iLigMaxExcel)
        SQL = Replace(SQL, "[@limiteMax]", iLimInf + i * iLigMaxExcel)
        Qdf.SQL = SQL
 
        'Création du recordset
        Set Rs = CurrentDb.OpenRecordset(Qdf.Name)
        If Not Rs.BOF Then Rs.MoveFirst
 
        'Definition des colonnes
        For iCols = 0 To Rs.Fields.Count - 1
            oSheet.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name
        Next iCols
 
        'Remplissage des colonnes avec les données
        oSheet.Range("A2").CopyFromRecordset Rs
 
        'Mise en place de valeurs de validation
        On Error GoTo 0
        With oSheet.Range("R2:R" & Rs.RecordCount + 1).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="" & sListeTypageValide
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "Typages des suspens autorisés"
            .ErrorTitle = "Typage de suspens invalide"
            .InputMessage = "Merci de saisir un typage de suspens valide"
            .ErrorMessage = "Le typage de suspens saisi est invalide. Merci de saisir un typage valide dans la liste."
            .ShowInput = True
            .ShowError = True
        End With
 
        'Mise en forme de la feuille
        oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 256)).Font.Bold = True
        oSheet.Rows("1:1").AutoFilter
        oSheet.Cells.Font.Size = 8
        oSheet.Range("K:M").Style = "Comma"
        oSheet.Range("T:T").Style = "Comma"
        oSheet.Cells.EntireColumn.AutoFit
 
        'Purge des colonnes non désirées mais nécessaires dans la requête
        oSheet.Range(oSheet.Cells(1, 31), oSheet.Cells(1, 37)).EntireColumn.Delete
 
        'Purge des objets
        Rs.Close
        Set Rs = Nothing
        'On réinitialise le SQL de notre requête générique
        Qdf.SQL = SQL_Generique
 
    Next i
    '==================================================================
 
 
 
    'EXPORT DE LA VERIFICATION DES SOLDES
    '==================================================================
    Set oSheet = oWkb.Worksheets(iMax)
    oSheet.Activate
    oSheet.Name = "VERIFICATION DES SOLDES"
 
    Set Qdf = CurrentDb.QueryDefs("RCB_VERIFICATION_DES_SOLDES_" & sUser)
    Qdf.SQL = Replace(Qdf.SQL, "[@ID_NOSTRO]", j)
    Set Rs = CurrentDb.OpenRecordset(Qdf.Name)
    If Not Rs.BOF Then Rs.MoveFirst
 
    'Definition des colonnes
    For iCols = 0 To Rs.Fields.Count - 1
        oSheet.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name
    Next iCols
    'Remplissage des colonnes avec les données
    oSheet.Range("A2").CopyFromRecordset Rs
 
    'Complement d'information
    oSheet.Range("J1").Value = "SOLDE_RCB"
    oSheet.Range("K1").Value = "ECART_SUSPENS"
    SQL = ""
    For i = 1 To iMax - 1
        Set oSheet = oWkb.Worksheets(i)
        oSheet.Rows("1:1").AutoFilter Field:=10, Criteria1:="BANQUE"
        oSheet.Range(oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)), oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)).End(xlToRight)).Font.ColorIndex = 3
        oSheet.Rows("1:1").Font.ColorIndex = 0
        oSheet.Rows("1:1").AutoFilter
        oSheet.Rows("1:1").AutoFilter
 
        SQL = SQL + "+SUM((RC[-7]='SUSPENS " & i & "'!RC[-4]:R[65534]C[-4])*(RC[-6]='SUSPENS " & i & "'!RC[-3]:R[65534]C[-3])*(RC[-5]='SUSPENS " & i & "'!RC[-2]:R[65534]C[-2])*'SUSPENS " & i & "'!RC[3]:R[65534]C[3])"
    Next i
 
    Set oSheet = oWkb.Worksheets(iMax)
 
    iMax = oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 1).End(xlDown)).Row + 1
 
    oSheet.Range(oSheet.Cells(2, 10), oSheet.Cells(iMax, 10)).FormulaArray = "=" & SQL
    oSheet.Range(oSheet.Cells(2, 11), oSheet.Cells(iMax, 11)).FormulaR1C1 = "=RC[-1]-RC[-3]-RC[-2]"
 
    'Mise en forme de la feuille
    oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(1, 256)).Font.Bold = True
    oSheet.Rows("1:1").AutoFilter
    oSheet.Cells.Font.Size = 8
    For i = 2 To iMax
        oSheet.Range("G2:G" & i).Value = CDbl(oSheet.Range("G2:G" & i).Value)
        oSheet.Range("H2:H" & i).Value = CDbl(oSheet.Range("H2:H" & i).Value)
        oSheet.Range("I2:I" & i).Value = CDbl(oSheet.Range("I2:I" & i).Value)
    Next i
 
    oSheet.Range("G:K").Style = "Comma"
    oSheet.Cells.EntireColumn.AutoFit
 
    'Purge des objets
    Rs.Close
    Set Rs = Nothing
    Set Qdf = Nothing
    '==================================================================
 
    oWkb.SaveAs URL, xlWorkbookNormal
    oWkb.Close
    Set oWkb = Nothing
    Set oSheet = Nothing
 
Next j
 
'Fermeture de l'instance Excel et purge de l'objet
oExcel.SheetsInNewWorkbook = 3
oExcel.Quit
Set oExcel = Nothing
 
ExportSuspensNOSTRO = True
 
End Function

Erreur d'exécution '-2147417856 (80010100)': La méthode 'CopyFromRecordset' de l'objet 'Range' a échoué

VBA Access

Discussions similaires

Partager

Partager