Import excel dans access Résolu/Fermé

Question

Bonjour,

 Je cherche à mettre mon code vba Excel sous access mais j' y arrive pas! Je vous explique: Il s'agit d'un code qui fait de l' import des colonnes excel dans une table access, sauf que le code je le mettais sous excel; maintenant, Je souhaite mettre le code sous access, comme ça je peux faire cet import à partir de n'importe quel fichier excel vers ma base access. 
 


 Sub ADOFromExcelToAccess()
 Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
 Chemin = ActiveWorkbook.Path
 Set db = OpenDatabase("chemin database.mdb")
 Source = Chemin & "\database name"
 Set cn = New ADODB.Connection
 cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source= " & Source & ";"

' open a recordset
 Set rs = New ADODB.Recordset
 rs.Open "[MA TABLE ACCESS]", cn, adOpenKeyset, adLockOptimistic, adCmdTable ' all records in a table

r = 2 ' the start row in the worksheet
 Do While Len(Range("A" & r).Formula) > 0 ' repeat until first empty cell in column A
 
With rs
 .AddNew ' create a new record
 ' add values to each field in the record
 .Fields("COL1") = Range("A" & r).Value
 .Fields("COL2") = Range("B" & r).Value

.Update ' stores the new record
 End With
 r = r + 1 ' next row
 Loop
 rs.Close
 Set rs = Nothing
 cn.Close
 Set cn = Nothing
 End Sub

 Merci d'avance,

michel_m · Answer

Bonjour 
normalement pour inscrire un nouvel enregistrement dans une database on utilise une requete avec la syntaxe "insert to" de SQL
ci dessous un exemple d'archivage de facture d'une feuille Excel (XL<2007)
vers la table T_archives de suivi_affaires.mdb
Sub archiver_Access()Dim conn As ObjectDim requete As ObjectDim f_num As Long, f_date As Date, c_num As String, e_date As Date, totalHT As DoubleDim base_ac As String, fichier As String, texte_SQL As String'---------collecte les infos de la facturef_num = Range("A14")f_date = Range("A16")c_num = CStr(Range("C16"))e_date = Range("H16")totalHT = Range("F43")'-------connexion à la base dans fichier archives.xlsbase_ac = "Suivi_affaire.mdb" 'a adapterfichier = ThisWorkbook.Path & "\" & base_ac 'a adapterSet conn = CreateObject("ADODB.Connection")conn.Open "Provider = Microsoft.Jet.OLEDB.4.0;" & _                "data source=" & fichier & ";"                '----------- travail demandé: insère dans les champs de "T_archive les données collectéestexte_SQL = "INSERT INTO T_archive (num_fact,dat_fact,num_comm,echeance,montant_HT) VALUES ('" & (f_num) & "','" & (f_date) & "', '" & (c_num) & "','" & (e_date) & "', '" & (totalHT) & "')"' éxécute le travail demandéSet requete = CreateObject("ADODB.recordset")On Error GoTo alerte 'cas où la facture (numéro) a déjà été enregistréeSet requete = conn.Execute(texte_SQL)'---------------déroulement normalMsgBox "archivage de la facture n° " & f_num & " effectué avec succès"Set requete = NothingSet conn = NothingExit Sub'------------- gestionnaire erreurs' facture déjà enregistréealerte:MsgBox "la facture n° " & f_num & " a déjà été enregistrée!", vbCriticalSet requete = NothingSet conn = NothingEnd Sub

Si les fichiers de ce code xl-access t'intéressent, fais signe  
 
 Michel

f894009 · Answer

Bonjour tout le monde,

maintenant, Je souhaite mettre le code sous access

code VBA Access:
Recuparation donnees feuille excel et ecriture dans table Access 

une facon de faire:

Sub DataExcel_Access()
    Dim Rsxl As ADODB.Recordset, r As Long
    Dim rs As Recordset
    Dim cnxl As ADODB.Connection
    Dim Cd As ADODB.Command
    
    Set db = CurrentDb
    ' open a recordset: nom de table a adapter
    SQL = "Select * From [Migration Geotec_1- Côte Nord]"
    Set rs = CurrentDb.OpenRecordset(SQL)
    'a adapter
    Fichier = "D:\_Docs_Prog_Excel\ADODB_excel\fichier_test1.xlsx"
    
    Set cnxl = New ADODB.Connection
    Set Cd = New ADODB.Command
    Set Rsxl = New ADODB.Recordset
    With cnxl
        .ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & Fichier & ";ReadOnly=0;HDR=YES"
        .Open
    End With
    Cd.ActiveConnection = cnxl
    'mettre le nom de le feuille et les colonnes a selectionner
    Cd.CommandText = " SELECT * FROM [fichier_test$A:B]"
    'creation recordset feuille excel
    Rsxl.Open Cd, , adOpenKeyset, adLockOptimistic
    'boucle sur le recordset
    Do While Not Rsxl.EOF
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields(0) = Rsxl(0)        'nom de champ ou numero a adapter
            .Fields(1) = Rsxl(1)        'nom de champ ou numero a adapter
            .Update ' stores the new record
        End With
        Rsxl.MoveNext
    Loop
    
    MsgBox "Ajout termine"
    
    rs.Close
    Set rs = Nothing
    cnxl.Close
    Set cnxl = Nothing
    Set Cd = Nothing
    Set Rsxl = Nothing
End Sub

Sarah_Ber · Answer

Merci f894009!
J'ai eu cette erreur en fin d'exécution due à l'utilisation de "MoveNext".

Sarah_Ber · Answer

Voici mon code en entier.


Sub DataExcel_Access()
    Dim Rsxl As ADODB.Recordset, r As Long
    Dim rs As Recordset
    Dim cnxl As ADODB.Connection
    Dim Cd As ADODB.Command
    
    Set db = CurrentDb
    ' open a recordset: nom de table a adapter
    SQL = "Select * From [EXTRACTED_RECORDS]"
    Set rs = CurrentDb.OpenRecordset(SQL)
    'a adapter
    Fichier = "C:\Users\Desktop\BD\EXTRACT_XLTOACCESS.xlsm"
    
    Set cnxl = New ADODB.Connection
    Set Cd = New ADODB.Command
    Set Rsxl = New ADODB.Recordset
    With cnxl
        .ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & Fichier & ";ReadOnly=0;HDR=YES"
        .Open
    End With
    Cd.ActiveConnection = cnxl
    'mettre le nom de le feuille et les colonnes a selectionner
    Cd.CommandText = " SELECT * FROM [Results$A:L]"
    'creation recordset feuille excel
    Rsxl.Open Cd, , adOpenKeyset, adLockOptimistic
    'boucle sur le recordset
    Do While Not Rsxl.EOF
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields(0) = Rsxl(0)        
            .Fields(1) = Rsxl(1)        
            .Fields(2) = Rsxl(2)        
            .Fields(3) = Rsxl(3)        
            .Fields(4) = Rsxl(4)       
            .Fields(5) = Rsxl(5)        
            .Fields(6) = Rsxl(6)        
            .Fields(7) = Rsxl(7)        
            .Fields(8) = Rsxl(8)        
            .Fields(9) = Rsxl(9)        
            .Fields(10) = Rsxl(10)        
            .Fields(11) = Rsxl(11)        
            .Update ' stores the new record
        End With
        Rsxl.MoveNext
    Loop
    
    MsgBox "Ajout termine"
    
    rs.Close