Option Explicit
 
'Outils | Reference MS Active Data Objects x.x Library
 
 
Sub ImportDonnées()
Dim Connexion As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim CheminBase As String
Dim CompteChamps As Long
Dim Requete As String
Dim i As Integer
Dim NomTable As String
     
    CheminBase = ThisWorkbook.Path & "\" & "CPASAN.mdb"
    NomTable = "cpasan"
     
    Cells(1, 1).CurrentRegion.Clear
     
    Connexion.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & CheminBase & ";"
     
    Requete = "SELECT [NOM],[PRENOM],[UNITE]" _
            & " FROM " & NomTable & "" _
            & " WHERE ([PRESENT]= -1) AND" _
            & " ([DISPONIBLE] = 0) " _
            & " ORDER BY [UNITE] ASC, [NOM] DESC;"
     
    With Rs
        .CursorLocation = adUseClient
        .Open Requete, Connexion, adOpenDynamic, adLockOptimistic
    End With
     
    CompteChamps = Rs.Fields.Count
    For i = 0 To CompteChamps - 1
        Cells(1, i + 1).Value = Rs.Fields(i).Name
    Next
     
    Cells(2, 1).CopyFromRecordset Rs
     
    Set Rs = Nothing
    Set Connexion = Nothing
End Sub

Option Explicit
 
'Cocher Outils References ActiveX Data Objects x.x Object Library.
 
Public Sub ADOImportTableAccess(FichierBaseAccess As String, NomTable As String, Cible As Range)
Dim Connexion As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim i As Integer
Dim Requete As String
                 
    Set Connexion = New ADODB.Connection
    Connexion.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & FichierBaseAccess & ";"
     
    Set Rs = New ADODB.Recordset
     
    Requete = "SELECT NOM, PRENOM, AILE, CHAMBRE, UNITE FROM " & NomTable & " WHERE (PRESENT = -1) AND (DISPONIBLE = 0) ORDER BY UNITE ASC,NOM ASC"
 
    With Rs
        .CursorLocation = adUseClient
        .Open Requete, Connexion, adOpenDynamic, adLockOptimistic
 
        For i = 0 To Rs.Fields.Count - 1
            Cible.Offset(0, i).Value = Rs.Fields(i).Name
        Next
        Cible.Offset(1, 0).CopyFromRecordset Rs
    End With
     
    Rs.Close
    Set Rs = Nothing
     
    Connexion.Close
    Set Connexion = Nothing
End Sub
 
Sub Bouton1_QuandClic()
Dim Chemin As String
Dim NomTable As String
Dim Cible As Range
 
    Application.ScreenUpdating = False
        Cells.Clear
         
        Chemin = ThisWorkbook.Path & "\Cpasan.mdb"
        NomTable = "CPASAN"
        Set Cible = Cells(1, 1)
         
        ADOImportTableAccess Chemin, NomTable, Cible
         
        Cells.Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Range("A1" ).Select
    Application.ScreenUpdating = True
End Sub

Sub Excel2Access(FichierBaseAccess As String, NomTable As String)
Dim Connexion As ADODB.Connection
Dim ChaineConnexion As String
Dim Requete As String
Dim strNom, strPrenom, strNomJFille As String
Dim strLieuNaissance, strSexe As String
Dim strSituaFam, strDernierAdr As String
Dim strVille, strMedTraitant, strCaisse As String
Dim strComplement, strCategorie, strModSortie As String
Dim strService, strUnite As String
Dim strDiag, strAdresses As String
Dim strAile As String, iNbJours As Long, iNPP As Long
Dim iChambre As Integer, iCp As Long, iAgeAct As Integer
Dim dNumSecu As Double, iType As Integer
Dim iALD As Integer, iPresent As Integer, iDisponible As Integer
Dim strProvenance As String, DateNais As Date
Dim DateEntree As Date, DateSortiePre As Date, DateSortie As Date
     
    strNom = "Kiki"
    strPrenom = "essai"
    strNomJFille = ""
    DateNais = #7/15/1986#
    DateEntree = #9/9/9999#
    DateSortiePre = #10/9/9999#
    DateSortie = #11/9/9999#
    strLieuNaissance = "NoWhere"
    strSexe = "M"
    iAgeAct = 20
    strSituaFam = "C"
    strDernierAdr = "Somewhere"
    strVille = "Quimper"
    strMedTraitant = "Veto"
    strCaisse = "en bois"
    dNumSecu = 1234567890123#
    strComplement = ""
    strService = "OUDN"
    strUnite = "OUDN1"
    iCp = CLng(29000)
    strCategorie = ""
    iChambre = 512
    iType = 99
    iNbJours = CLng(DateDiff("d", DateEntree, DateSortie))
    iNPP = 99999
    strProvenance = "Hopital"
    strModSortie = "Taxi"
    strAile = "E"
    iALD = -1
    iPresent = -1
    iDisponible = 0
    strDiag = ""
    strAdresses = "10 rue des Morillons Paris"
     
    ChaineConnexion= "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & FichierBaseAccess & ";"
     
    Requete = "INSERT INTO " & NomTable & " (NOM,PRENOM,NOMJFILLE,DATE_NAIS,LIEU_NAIS,SEXE,AGE_ACT,SITUAFAM," & _
                                        "DERNIERADR,VILLE,CP,MEDTRAITAN,CAISSE,NUMERO,COMPLEMENT,ALD," & _
                                        "NPP,CATEGORIE,ENTREE,PROVENANCE,SORTIE_PRE,SORTIE,MOD_SORTIE,PRESENT," & _
                                        "SERVICE,AILE,CHAMBRE,TYPE,NB_JOURS,DISPONIBLE,ADRESSES,DIAG,UNITE)" & _
                                        "VALUES " & _
                                        "( '" & strNom & "','" & _
                                            strPrenom & "','" & _
                                            strNomJFille & "','" & DateNais & "','" & strLieuNaissance & "','" & _
                                            strSexe & "'," & iAgeAct & ",'" & strSituaFam & "','" & _
                                            strDernierAdr & "','" & strVille & "'," & iCp & ",'" & strMedTraitant & " ','" & _
                                            strCaisse & "'," & dNumSecu & ",'" & strComplement & "'," & iALD & "," & iNPP & ",'" & _
                                            strCategorie & "','" & DateEntree & "','" & strProvenance & "','" & DateSortiePre & "','" & DateSortie & "','" & strModSortie & "'," & iPresent & ",'" & _
                                            strService & "','" & strAile & "'," & _
                                            iChambre & "," & iType & "," & iNbJours & "," & iDisponible & ",'" & _
                                            strAdresses & "','" & strDiag & "','" & strUnite & "');"
    Set Connexion = New ADODB.Connection
    With Connexion
        .Open ChaineConnexion
        .CursorLocation = adUseClient
        .Execute (Requete)
    End With
     
    Connexion.Close
    Set Connexion = Nothing
End Sub

 i = 3  
 rst.MoveFirst  <==
 While Not rst.EOF  
     Cells(5, i).Value = rst.Fields("PLAN1_CENTRE" ).Value  
     rst.MoveNext  
     i = i + 1  
Wend