XL 2013 VBA erreur d'exécution export vers Access

C

chacal33

XLDnaute Junior
Bonsoir à toutes et à tous.

J'ai un fichier Excel avec beaucoup de données et mon objectif est d'exporter ces données dans une base Access, et lorsque les données dans Excel sont mises à jour, je souhaiterais que les données dans Access soient aussi mises à jour.

J'ai donc une macro qui fonctionne bien pour la création, mais pour la modification, j'ai une erreur qui apparait et qui bloque le reste de la macro.

Voici le code en question:

Code: 
Private Sub TRANSPOSEACCESS()

On Error GoTo myEnd
    ' exports data from the active worksheet to a table in an Access database this procedure must be edited before use
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long

    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & "Data Source=C:\Users\Emilie\Desktop\DANWARE.accdb;Persist Security Info=False;"

    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "T_POSE", 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("Chantier") = Range("A" & r).Value
            .Fields("Zone") = Range("B" & r).Value
            .Fields("Prestation") = Range("C" & r).Value
            .Fields("Unite") = Range("D" & r).Value
            .Fields("Qte") = Range("E" & r).Value
            .Fields("PU") = Range("F" & r).Value
            .Fields("TotalNet") = Range("G" & r).Value
            .Fields("Qui") = Range("H" & r).Value
            .Fields("Type") = Range("I" & r).Value
            .Fields("Avct") = Range("J" & r).Value
            .Fields("DatePose") = Range("K" & r).Value
            .Fields("QteAvct") = Range("L" & r).Value
            .Fields("MontantAvctNet") = Range("M" & r).Value
            .Fields("Notes") = Range("N" & r).Value
            .Fields("QteBase") = Range("O" & r).Value
            .Fields("FactureST") = Range("P" & r).Value
            .Fields("DateFactureST") = Range("Q" & r).Value
            .Fields("NumFactureST") = Range("R" & r).Value
            .Fields("XLSBDID") = Range("S" & r).Value
            ' .Fields("DevisDetailID") = Range("H" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record


        End With
        r = r + 1 ' next row
    Loop
On Error Resume Next

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

myEnd:

Sheets("EXPORT").Select
Dim cnx As ADODB.Connection, rsx As ADODB.Recordset, rx As Long
Dim cd As New ADODB.Command

' connect to the Access database
Set cnx = New ADODB.Connection
cnx.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & "Data Source=C:\Users\Emilie\Desktop\DANWARE.accdb;Persist Security Info=False;"

' open a recordset
Set rsx = New ADODB.Recordset
rsx.Open "T_POSE", cnx, adOpenKeyset, adLockOptimistic, adCmdTable
cd.ActiveConnection = cnx
   
    rx = 2 ' the start row in the worksheet
    Do While Len(Range("A" & rx).Formula) > 0

    ' repeat until firsxt empty cell in column A
        With rsx
        cd.CommandText = "UPDATE [T_POSE] SET [Chantier] = '" & Range("A" & rx).Value & "',[Zone] = '" & Range("B" & rx).Value & "',[Prestation] = '" & Range("C" & rx).Value & "',[Unite] = '" & Range("D" & rx).Value & "',[Qte] = '" & Range("E" & rx).Value & "',[PU] = '" & Range("F" & rx).Value & "',[TotalNet] = '" & Range("G" & rx).Value & "',[Qui] = '" & Range("H" & rx).Value & "',[Type] = '" & Range("I" & rx).Value & "',[Avct] = '" & Range("J" & rx).Value & "',[DatePose] = '" & Range("K" & rx).Value & "', [QteAvct] = '" & Range("L" & rx).Value & "',[MontantAvctNet] = '" & Range("M" & rx).Value & "',[Notes] = '" & Range("N" & rx).Value & "',[QteBase] = '" & Range("O" & rx).Value & "',[FactureST] = '" & Range("P" & rx).Value & "',[DateFactureST] = '" & Range("Q" & rx).Value & "',[NumFactureST] = '" & Range("R" & rx).Value & "',[XLSBDID] = '" & Range("Q" & rx).Value & "' WHERE [XLSBDID] = '" & Range("S" & rx).Value & "'"
        cd.Execute
'              MsgBox (cd.CommandText) 'debug
         End With
        rx = rx + 1 ' next row
    Loop
     rsx.Close
     Set rsx = Nothing
     cnx.Close
     Set cnx = Nothing

End Sub

Comment faire pour qu'il n'y ait pas d'erreur?

Merci de votre retour.

Matt
 

Pièces jointes

  • excel.jpg
    excel.jpg
    32.7 KB · Affichages: 62
Trier par date Trier par votes
C

chacal33

XLDnaute Junior
Bonjour,

J'ai enfin eu le temps d'essayer ta proposition Pierre.
Et j'ai une erreur de syntaxe dans l'expression : "Chantier WHERE XLSBDID = "
A priori dans la ligne de la function suivante:
Rst.Open Req, Cnx, 3

De mon côté, j'ai avancé sur le sujet; cependant, je ne comprends pas pourquoi, mais c'est infiniment lent...

VB: 
Private Sub TRANSPOSEACCESS()
'Application.ScreenUpdating = False

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim Chantier As String, Zone As String, Prestation As String, Unite As String, Qte As Single, PU As Single, TotalNet As Single, Qui As String, TypeMOP As String, Avct As Single, DatePose As Date, QteAvct As Single, MontantAvctNet As Single, Notes As String, QteBase As Single, FactureST As Single, DateFactureST As Date, NumFactureST As String, XLSBDID As String
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
    "Data Source=Z:\POSE\DANWARE\DANWARE.accdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "T_POSE", cn, adOpenKeyset, adLockOptimistic, adCmdTable

Sheets("EXPORT").Range("A2").Activate  ' row 1 contains column headings
Do While Not IsEmpty(ActiveCell)
    Chantier = ActiveCell.Value
    Zone = ActiveCell.Offset(0, 1).Value
    Prestation = ActiveCell.Offset(0, 2).Value
    Unite = ActiveCell.Offset(0, 3).Value
    Qte = ActiveCell.Offset(0, 4).Value
    PU = ActiveCell.Offset(0, 5).Value
    TotalNet = ActiveCell.Offset(0, 6).Value
    Qui = ActiveCell.Offset(0, 7).Value
    TypeMOP = ActiveCell.Offset(0, 8).Value
    Avct = ActiveCell.Offset(0, 9).Value
    DatePose = ActiveCell.Offset(0, 10).Value
    QteAvct = ActiveCell.Offset(0, 11).Value
    MontantAvctNet = ActiveCell.Offset(0, 12).Value
    Notes = ActiveCell.Offset(0, 13).Value
    QteBase = ActiveCell.Offset(0, 14).Value
    FactureST = ActiveCell.Offset(0, 15).Value
    DateFactureST = ActiveCell.Offset(0, 16).Value
    NumFactureST = ActiveCell.Offset(0, 17).Value
    XLSBDID = ActiveCell.Offset(0, 18).Value
   
    rs.Filter = "XLSBDID='" & XLSBDID & "'"
    If rs.EOF Then
        Debug.Print "No existing record - adding new..."
        rs.Filter = ""
        rs.AddNew
        rs("Chantier").Value = Chantier
        rs("Zone").Value = Zone
        rs("Prestation").Value = Prestation
        rs("Unite").Value = Unite
        rs("Qte").Value = Qte
        rs("PU").Value = PU
        rs("Qui").Value = Qui
        rs("TypeMOP").Value = TypeMOP
        rs("Avct").Value = Avct
        rs("DatePose").Value = DatePose
        rs("QteAvct").Value = QteAvct
        rs("MontantAvctNet").Value = MontantAvctNet
        rs("Notes").Value = Notes
        rs("QteBase").Value = QteBase
        rs("FactureST").Value = FactureST
        rs("DateFactureST").Value = DateFactureST
        rs("NumFactureST").Value = NumFactureST
        rs("XLSBDID").Value = XLSBDID
    Else
        Debug.Print "Existing record found..."
    End If
        rs("Zone").Value = Zone
        rs("Prestation").Value = Prestation
        rs("Unite").Value = Unite
        rs("Qte").Value = Qte
        rs("PU").Value = PU
        rs("Qui").Value = Qui
        rs("TypeMOP").Value = TypeMOP
        rs("Avct").Value = Avct
        rs("DatePose").Value = DatePose
        rs("QteAvct").Value = QteAvct
        rs("MontantAvctNet").Value = MontantAvctNet
        rs("Notes").Value = Notes
        rs("QteBase").Value = QteBase
        rs("FactureST").Value = FactureST
        rs("DateFactureST").Value = DateFactureST
        rs("NumFactureST").Value = NumFactureST
    rs.Update
    Debug.Print "...record update complete."

    ActiveCell.Offset(1, 0).Activate  ' next cell down
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

'Application.ScreenUpdating = True
End Sub

Je suis preneur pour une solution qui va plus vite...

Merci!

Matt
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
439
florian50470
F
J
  • Question
XL 2016 VBA : Erreur automation - requête sur un fichier ouvert
Réponses
1
Affichages
956
fanch55
fanch55
T
  • Question
XL 2019 Pb de valeurs récupérées par une requête SQL en VBA
Réponses
14
Affichages
2 K
tibofo
T
B
  • Question
Afficher les resultats de recherche dans une base de donnée MySQL dans une ListBox VBA
Réponses
0
Affichages
1 K
Benam
B
B
  • Question
XL 2016 Connexion entre VBA-Excel et Mysql
Réponses
8
Affichages
11 K
Benam
B
R
  • Question
Requête SQL - problème date - where - récupération celllule
2
Réponses
18
Affichages
6 K
rcan7412
R
E
  • Question
XL 2010 Vba - Copier data excel vers Acess
Réponses
3
Affichages
1 K
Evictius
E
C
  • Question
Update table accès depuis excel via recordset Ado
Réponses
3
Affichages
3 K
ceddeg
C
C
  • Question
XL 2013 Import données Access avec db ouverte
Réponses
0
Affichages
622
chacal33
C
S
  • Question
Macro transfer donnée dans MS Access
Réponses
3
Affichages
754
tototiti2008
tototiti2008

Membres actuellement en ligne

3 membres et 43 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 098
Messages
2 116 189
Membres
112 679
dernier inscrit
Yupanki