Envoyer données vers Excel plus vite...Résolu

Question

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

Renfield · Accepted Answer

commence par éviter n fois

.Workbooks(1).Worksheets(1).

joues avec With

cs_petchy · Answer

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

cs_petchy · Answer

et c'est vrai c'est plus rapide

Envoyer données vers Excel plus vite...

3 réponses

Votre réponse

Discussions similaires