Envoyer données vers Excel plus vite...

Résolu
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 - 20 avril 2009 à 16:34
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 - 21 avril 2009 à 18:06
bonjour
j'ai se code pour envoyer des données de VB6 vers une feuille EXCEL,mais c'est lent,aurait une solution pour que ça aille un peu plus vite

Sub exportexcel()

If Frm_Exportation.ListView1.ListItems.Count = 0 Then Exit Sub
'**************Lance la procédure pour exporter la facture au format excel*************************************
On Error GoTo err
Dim i_Ligne As Long

Set XlApp = CreateObject("excel.application")

Set rst = dbs.OpenRecordset("SELECT * FROM [T_Record]where [T_Numfacture]='" & ListView1.ListItems.Text & "'")
rst.MoveLast
rst.MoveFirst
'********Ouvrir le classeur excel **********
With XlApp
XlApp.Visible = True
.Workbooks.Open App.Path & "\Facture.xls"

'*************Feuille 1***************************************************************************************
.Workbooks(1).Worksheets(1).Cells(8, 6) = rst.Fields(3)
.Workbooks(1).Worksheets(1).Cells(9, 6) = rst.Fields(4)
.Workbooks(1).Worksheets(1).Cells(11, 6) = rst.Fields(5)
.Workbooks(1).Worksheets(1).Cells(14, 2) = Frm_Exportation.cb1.Text & " N°"
.Workbooks(1).Worksheets(1).Cells(14, 3) = UCase(rst.Fields(0))
.Workbooks(1).Worksheets(1).Cells(15, 3) = rst.Fields(19)
.Workbooks(1).Worksheets(1).Cells(53, 9) = Format(rst.Fields(8)) & "€"
.Workbooks(1).Worksheets(1).Cells(54, 9) = Format(rst.Fields(9)) & " €"
.Workbooks(1).Worksheets(1).Cells(54, 7) = "Remise de " & rst.Fields(11) & "%"
.Workbooks(1).Worksheets(1).Cells(55, 9) = Format(rst.Fields(25)) & " €"
.Workbooks(1).Worksheets(1).Cells(56, 9) = Format(rst.Fields(10)) & " €"
.Workbooks(1).Worksheets(1).Cells(58, 9) = Format(rst.Fields(16)) & " €"
.Workbooks(1).Worksheets(1).Cells(60, 9) = Format(rst.Fields(17)) & " €"
.Workbooks(1).Worksheets(1).Cells(59, 9) = Format(rst.Fields(18)) & " €"
Set rst0 = dbs.OpenRecordset("SELECT * FROM [T_Facture_personne] where [T_Numfacture]='" & rst.Fields(0) & "'")
rst0.MoveLast
rst0.MoveFirst

For a = 1 To rst0.RecordCount
.Workbooks(1).Worksheets(1).Cells(18 + a, 2) = UCase(rst0.Fields(1))
.Workbooks(1).Worksheets(1).Cells(18 + a, 6) = UCase(rst0.Fields(6))
.Workbooks(1).Worksheets(1).Cells(18 + a, 7) = UCase(rst0.Fields(3))
.Workbooks(1).Worksheets(1).Cells(18 + a, 8) = UCase(rst0.Fields(5))
.Workbooks(1).Worksheets(1).Cells(18 + a, 9) = UCase(rst0.Fields(10)) '& " €"
rst0.MoveNext
Next a

'***************Feuille 2*************************************************************************************
.Workbooks(1).Worksheets(2).Cells(8, 6) = rst.Fields(3)
.Workbooks(1).Worksheets(2).Cells(9, 6) = rst.Fields(4)
.Workbooks(1).Worksheets(2).Cells(11, 6) = rst.Fields(5)
.Workbooks(1).Worksheets(2).Cells(14, 2) = Frm_Exportation.cb1.Text & " N°"
.Workbooks(1).Worksheets(2).Cells(14, 3) = UCase(rst.Fields(0))
.Workbooks(1).Worksheets(2).Cells(15, 3) = rst.Fields(19)
.Workbooks(1).Worksheets(2).Cells(53, 9) = Format(rst.Fields(12)) & "€"
.Workbooks(1).Worksheets(2).Cells(54, 9) = Format(rst.Fields(13)) & " €"
.Workbooks(1).Worksheets(2).Cells(54, 7) = "Remise de " & rst.Fields(15) & "%"
.Workbooks(1).Worksheets(2).Cells(55, 9) = Format(rst.Fields(26)) & " €"
.Workbooks(1).Worksheets(2).Cells(56, 9) = Format(rst.Fields(14)) & " €"
.Workbooks(1).Worksheets(2).Cells(58, 9) = Format(rst.Fields(16)) & " €"
.Workbooks(1).Worksheets(2).Cells(60, 9) = Format(rst.Fields(17)) & " €"
.Workbooks(1).Worksheets(2).Cells(59, 5) = Format(rst.Fields(18)) & " €"

Set rst0 = dbs.OpenRecordset("SELECT * FROM [T_Facture_matières] where [T_Numfacture]='" & rst.Fields(0) & "'")
rst0.MoveLast
rst0.MoveFirst

For a = 1 To rst0.RecordCount
.Workbooks(1).Worksheets(2).Cells(18 + a, 2) = UCase(rst0.Fields(1))
.Workbooks(1).Worksheets(2).Cells(18 + a, 6) = UCase(rst0.Fields(6))
.Workbooks(1).Worksheets(2).Cells(18 + a, 7) = UCase(rst0.Fields(3))
.Workbooks(1).Worksheets(2).Cells(18 + a, 8) = UCase(rst0.Fields(5))
.Workbooks(1).Worksheets(2).Cells(18 + a, 9) = UCase(rst0.Fields(10)) '& " €"
rst0.MoveNext
Next a

rst.MoveNext

end With
Set appExcel = Nothing

err:
If err.Number = 3021 Then
If rst.RecordCount = 0 Then Exit Sub
Resume Next
End If

If err.Number = 1004 Then
XlApp.quit
Set XlApp = Nothing
MsgBox "Exportation annulée", vbCritical + vbOKOnly, "NTP"
Exit Sub
End If
Resume Next
End Sub

merci
@ plus
pascal

3 réponses

Renfield Messages postés 17287 Date d'inscription mercredi 2 janvier 2002 Statut Modérateur Dernière intervention 27 septembre 2021 71
20 avril 2009 à 16:45
commence par éviter n fois

.Workbooks(1).Worksheets(1).

joues avec With
3
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 3
21 avril 2009 à 18:05
bonjour
merci pour ta réponse,j'ai modifier tous le code
With XlApp
XlApp.Visible = True
.Workbooks.Open App.Path & "\Facture.xls"
.Workbooks(1).Worksheets (1)


.Range("F8").Value = rst.Fields(3) 'nom
.Range("F9").Value = rst.Fields(4) 'adresse
.Range("F11").Value = rst.Fields(5) 'code postal
etc.....
petchy
0
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 3
21 avril 2009 à 18:06
et c'est vrai c'est plus rapide
0