XL 2021 Importer les données Access dans Excel

[badraaliou4]

Salut,

J'ai ce code pour importer mes données à partir Access
mais le problème est que ma base de données est trop grande et l'importe est lente.
si quelqu'un peut m'aider à raccourcir l'exécution de mon code.
Merci l'avance

Sub ImportDataBase()
Dim CheminDB As String
Dim Critere As String: Dim Ligne As Integer
Dim EnR As Recordset: Dim Base As Database

CheminDB = ThisWorkbook.Path & "\FullDataBase.accdb"
Ligne = 2

Sheets("basetest").Select
'Call CleanBase

Set Base = DBEngine.OpenDatabase(CheminDB)
Set EnR = Base.OpenRecordset("TBBase")
EnR.MoveFirst
Do
   Cells(Ligne, 1).Value = EnR.Fields("Date").Value
   Cells(Ligne, 2).Value = EnR.Fields("Compte").Value
   Cells(Ligne, 3).Value = EnR.Fields("Service").Value
   Cells(Ligne, 4).Value = EnR.Fields("Narration").Value
   Cells(Ligne, 5).Value = EnR.Fields("Depot").Value
   Cells(Ligne, 6).Value = EnR.Fields("Retrait").Value
   Cells(Ligne, 7).Value = EnR.Fields("Achat").Value
   Cells(Ligne, 8).Value = EnR.Fields("Vente").Value
   Cells(Ligne, 9).Value = EnR.Fields("Taux").Value
   Cells(Ligne, 10).Value = EnR.Fields("Devise").Value
   Cells(Ligne, 11).Value = EnR.Fields("Coursieur").Value
   Cells(Ligne, 12).Value = EnR.Fields("Utilisateur").Value
   Cells(Ligne, 13).Value = EnR.Fields("Reference").Value
   Cells(Ligne, 14).Value = EnR.Fields("Option").Value
  
   Ligne = Ligne + 1
   EnR.MoveNext
  
Loop Until EnR.EOF = True

EnR.Close
Base.Close
Set EnR = Nothing
Set Base = Nothing
End Sub

 

[dysorthographie]

bonjour,

Sub ImportDataBase()
With CreateObject("AdoDb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\FullDataBase.accdb;Jet OLEDB:Database Password=;"
    Sheets("basetest").Range("A2").CopyFromRecordset .Execute("Select * From [TBBase]")
    .Close
End With
End Sub

 

[badraaliou4]

bonjour,

Sub ImportDataBase()
With CreateObject("AdoDb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\FullDataBase.accdb;Jet OLEDB:Database Password=;"
    Sheets("basetest").Range("A2").CopyFromRecordset .Execute("Select * From [TBBase]")
    .Close
End With
End Sub

Merci beaucoup
ça marche très bien