EFFECTUER DES IMPORTATIONS D'UNE BASE DE DONNÉE ACCESS VERS EXCEL EN VBA

Dim Db As DAO.Database 'Objet base de donnée
Dim Rs As Recordset 'Objet qui contient les résultats de la requête
Dim Debut As Date 'Sert à définir le temps d'exécution
Dim Fin As Date 'Sert à définir le temps d'exécution
Dim EnregistrementsParSecondes As Integer 'Nombre d'enregistrements traités par seconde
Dim NbrChamp As Integer 'Nombre de champ par enregistrement
Dim NbrEnr As Integer 'Nombre d'enregistrements traités
Dim Source As String 'C'est la requête
Dim ConditionsDeLaRequeteFinale As String 'Variable qui contiendras les conditions reformatées
Dim Flag As Boolean 'c'est juste un flag, un repère quoi !
Dim L As Integer 'Ligne actuelle
Dim C As Integer 'Colonne actuelle

Public Function ImporterResultatRequeteAccessDansExcel(FichierBaseDeDonneeMDB, NomTable, ConditionsDeLaRequete, NomFichierExcel, NomOngletExcel, Rapport As Boolean)

    'Pour que cette macro fonctionne, il faut référencer au minimum
    '"Microsoft DAO 2.5/3.5 Compatibility Library".
    'Mais la macro fonctionne aussi avec des librairies plus récentes comme
    '"Microsoft DAO 3.0 Object Library" et "Microsoft DAO 3.5 Object Library".
    
    'Cette macro fonctionne sur toutes les versions d'Excel (testé sur Excel 97)
    'et toutes les versions d'Access (testé sur Access 97) vu qu'elles sont rétrocompatibles !
    
    'Cette fonction permet d'importer le résultat d'une requete
    'effectuée dans une base de donnée Access à l'interieur d'un onglet Excel
    
    'Exemple de la commande à lancer pour appeler cette fonction :
    'Call ImporterResultatRequeteAccessDansExcel(ThisWorkbook.Path & "\BDD.mdb", "table_test", "WHERE commentaire=CarteOrange", ThisWorkbook.Name, 1, True)
    
    'Exemple de la commande à lancer pour importer toute une table :
    'Call ImporterResultatRequeteAccessDansExcel(ThisWorkbook.Path & "\BDD.mdb", "table_test", "", ThisWorkbook.Name, 1, True)
    
    '________________________________________________________________________________
    'Enregistrer le momment exact de l'exécution de la fonction
    'Cela sert à calculer le temps d'exécution de la fonction à la fin de celle-ci.
    Debut = Now
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Récupérer le nom exact de l'onglet dans lequel l'import sera fait
    NomOngletExcel = Workbooks(NomFichierExcel).Sheets(NomOngletExcel).Name
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Activer l'onglet pour l'import
    Workbooks(NomFichierExcel).Sheets(NomOngletExcel).Select
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Ouverture de la base de donnée Access.
    Set Db = DBEngine.OpenDatabase(FichierBaseDeDonneeMDB, False, False, "MS Access")
    '________________________________________________________________________________
    
    
    
    '________________________________________________________________________________
    'Ajout de guillemets derrière les "=" de la requete
    ConditionsDeLaRequeteFinale = ""
    Flag = False
    If Not ConditionsDeLaRequete = "" Then
        For i = 1 To Len(ConditionsDeLaRequete)
            If Mid$(ConditionsDeLaRequete, i, 1) = "=" Then
                    
                    Flag = True
                    ConditionsDeLaRequeteFinale = ConditionsDeLaRequeteFinale & Mid$(ConditionsDeLaRequete, i, 1) & Chr(34)
                    
                ElseIf Flag = True And Mid$(ConditionsDeLaRequete, i, 1) = " " Then
                    ConditionsDeLaRequeteFinale = ConditionsDeLaRequeteFinale & Chr(34) & Mid$(ConditionsDeLaRequete, i, 1)
                    Flag = False
                    
                ElseIf Flag = True And Not i = Len(ConditionsDeLaRequete) Then
                    ConditionsDeLaRequeteFinale = ConditionsDeLaRequeteFinale & Mid$(ConditionsDeLaRequete, i, 1)
                    
                ElseIf Flag = True And i = Len(ConditionsDeLaRequete) Then
                    ConditionsDeLaRequeteFinale = ConditionsDeLaRequeteFinale & Mid$(ConditionsDeLaRequete, i, 1) & Chr(34)
                    Flag = False
                    
                ElseIf Flag = False Then
                    ConditionsDeLaRequeteFinale = ConditionsDeLaRequeteFinale & Mid$(ConditionsDeLaRequete, i, 1)
                    
            End If
        Next
    End If
    '________________________________________________________________________________
    
    
    '________________________________________________________________________________
    'Définition de la requête qui seras effectuée dans la Base de données
    If Not ConditionsDeLaRequete = "" Then
            Source = "SELECT * FROM " & NomTable & " " & ConditionsDeLaRequeteFinale
        Else
            Source = "SELECT * FROM " & NomTable
    End If
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Effectuer la requête
    Set Rs = Db.OpenRecordset(Source)
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Définir le nombre d'enregistrements et de champs qui résultent de la requête.
    '
    'Les enregistrements sont les lignes de la base de données et les
    'champs sont en fait les colonnes.
    Rs.MoveLast
    NbrEnr = Rs.RecordCount
    Rs.MoveFirst
    NbrChamp = Rs.Fields.Count
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Ecrire les nom des champs en entête dans l'onglet du fichier Excel
    L = 1
    For C = 0 To NbrChamp - 1
        Workbooks(NomFichierExcel).Sheets(NomOngletExcel).Cells(L, C + 1) = Rs.Fields(C).Name
    Next
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Ecrire les résultats de la requête dans l'onglet du fichier Excel
    For L = 1 To NbrEnr
        For C = 0 To NbrChamp - 1
            Workbooks(NomFichierExcel).Sheets(NomOngletExcel).Cells(L + 1, C + 1) = Rs.Fields(C).Value
        Next
    Rs.MoveNext
    Next
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Cela sert à calculer le temps d'exécution de la fonction à la fin de celle-ci.
    Fin = Now
    '________________________________________________________________________________
    
    
    '________________________________________________________________________________
    'Mettre l'entête en gras, activer le filtrage automatique et redimensionner
    'les colonnes automatiquement.
    Rows("1:1").Select
    Selection.Font.Bold = True
    Selection.AutoFilter
    Cells.Select
    Selection.Columns.AutoFit
    Cells(2, 1).Select
    Cells(1, 1).Select
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Fermer la base de donnée
    Rs.Close
    Db.Close
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Libérer les objet utilisés pour la base de donnée
    Set Rs = Nothing
    Set Db = Nothing
    '________________________________________________________________________________
    
    '________________________________________________________________________________
    'Afficher le rapport final si il est demandé
    If Rapport = True Then
        Tps = DateDiff("s", Debut, Fin)
        If Tps > 0 Then
                EnregistrementsParSecondes = NbrEnr / Tps
            Else
                EnregistrementsParSecondes = NbrEnr
        End If
        MsgBox "Base de donnée : " & FichierBaseDeDonneeMDB & Chr(10) & _
               "Requête : " & Source & Chr(10) & Chr(10) & _
               "Fichier Excel : " & NomFichierExcel & Chr(10) & _
               "Nom de l'onglet : " & NomOngletExcel & Chr(10) & Chr(10) & _
               "Temps d'exécution : " & Tps & " secondes" & Chr(10) & _
               "Nombre d'enregistrements : " & NbrEnr & Chr(10) & _
               "Nombre d'enregistrements traités par secondes : " & EnregistrementsParSecondes & Chr(10) _
               , vbInformation, "Rapport de la requête"
    End If
    '________________________________________________________________________________
    
End Function