XL 2013 Import données Access avec db ouverte

[chacal33]

Bonjour à tous,

J'ai un fichier xlsm qui me permet d'importer des données d'une requête access.
Ce code fonctionne très bien lorsque la base de données est fermée, mais dès que la base de données est ouverte, Excel bloque...

Est-ce que quelqu'un aurait une idée ou déjà rencontré ce problème?

Je joints mon code vba:

Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer

DBFullName = "Z:\POSE\DANWARE\DANWARE.accdb"

Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect

Dim Nbre As String
Dim Message As String, Titre As String, Defaut As String, Reponse As String
Message = "Entrez le code:"
Titre = "SAISIE CODE"
Defaut = " "
Reponse = InputBox(Message, Titre, Defaut)
Nbre = (Reponse)

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_TransactionPxMAJLivree WHERE [Destination] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
For Col = 0 To Recordset.Fields.Count - 1
    Range("A10").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("A10").Offset(1, 0).CopyFromRecordset Recordset
End With

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_TransactionPxMAJRetour WHERE [Origine] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
    Range("A65000").End(xlUp).Offset(1).CopyFromRecordset Recordset
End With

ActiveSheet.Columns.AutoFit
   
    Sheets("TS").Select

    Rows("4:150").Delete Shift:=xlUp

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_TS WHERE [CodeChantier] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
For Col = 0 To Recordset.Fields.Count - 1
    Range("A4").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("A4").Offset(1, 0).CopyFromRecordset Recordset
End With

ActiveSheet.Columns.AutoFit

   
    Sheets("APPROS").Select

    Columns("A:BB").ClearContents

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_QuantiteProduitPrevue WHERE [CodeChantier] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
For Col = 0 To Recordset.Fields.Count - 1
    Range("U1").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("U1").Offset(1, 0).CopyFromRecordset Recordset
End With

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_QuantiteProduitLivree WHERE [CodeDestination] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
For Col = 0 To Recordset.Fields.Count - 1
    Range("Z1").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("Z1").Offset(1, 0).CopyFromRecordset Recordset
End With

ActiveSheet.Columns.AutoFit

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_QuantiteProduitRetournee WHERE [CodeOrigine] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection

    Range("Z65000").End(xlUp).Offset(1).CopyFromRecordset Recordset
End With

Set Recordset = Nothing
Connection.Close
Set Connection = Nothing

Merci de votre retour