Discussion :

[jfbonvin]

Bonjour,

Je veux mettre à jour une table Access nommé AIS_BudgetDATA.mdb depuis un fichier Excel voir pièce jointe.
L'ID a chercher dans Access se trouve dans la cellule ThisWorkbook.Sheets("PArametres").Range("B13")
La colonne Access où se trouve les ID se nomme ID

Pourriez-vous me dire comment adapter le code suivant (Excel à Excel) à une connexion avec une table Access ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Option Explicit
Sub TransfertDATA()
MajXls ThisWorkbook.Sheets("PArametres").Range("B13") 'Appel Sub MajXls en lui fournissan la valeur de JI en paramettre ID
End Sub
 
Sub MajXls(ID As String) 'procédure personnalisé avec passage de parametre ID!
 'On Error Resume Next
Application.ScreenUpdating = False
On Error GoTo ErrorUpdate
 
Dim Cn As New ADODB.Connection, Rs As New ADODB.Recordset, SQL As String, I As Integer, C As Integer 'Déclaration des variable
'je séléctionne tous les champs de la table Feuil1$ don ID est égale au parmetre passé à la procédure MajXls ThisWorkbook.Sheets("Feuil1").Range("J1")
SQL = "select * from [DATA$] WHERE ID=" & ID
 
    With Cn '==>Open connection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & ThisWorkbook.Sheets("Parametres").Range("B3") & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
      Rs.Open SQL, Cn, 1, 3 'execution de la requête
 
        With ThisWorkbook.Sheets("DATA")
            I = SerchXls(.Range("BR:BR"), .Range("BR1"), ID, True) 'Recherche la lige de ID
            If I = 0 Then Cn.Close: MsgBox "ID pas trouvé ! Bug": Exit Sub  'ID pas trouvé
            'S'il s'agit d'une nouvelle ligne alors cération d'un nouvelle ligne'Rs.AddNew
            If ThisWorkbook.Sheets("Parametres").Range("VerrouClient") = "New" Then
                MsgBox "Le nouveau budget va être ajouté !", vbInformation, "Informations"
                Rs.AddNew
            End If
            '
                'If Rs.EOF Then Rs.AddNew: MsgBox "Les données du nouveau budget vont être sauvgardées !", vbInformation, "Informations"  'Si la requête ne touve pas ID alors nouvel enregistrement
                For C = 0 To Rs.Fields.Count - 1
                    Rs.Fields(.Cells(1, "A").Offset(0, C).Value) = .Cells(I, "A").Offset(0, C).Value
                    'Rs.Fields(Trim(.Cells(1, "A").Offset(0, C).Value)) = .Cells(I, "A").Offset(0, C).Value 'charges les valeur dans le recordset
                Next
                Rs.Update 'met à jour le record set
        End With
        .Close
    End With
 
'MsgBox "Les données du client ont bien été sauvgardées !", vbInformation, "Informations"
 
Exit Sub
ErrorUpdate:
    On Error Resume Next
    MsgBox "Les données n'ont pas pu être sauvgardées en raison d'un problème technique !", vbCritical, "Informations"
End Sub
 
 
Function SerchXls(Myrange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Integer '
On Error Resume Next
SerchXls = 0
   SerchXls = Myrange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
        :=Array(xlPart, xlWhole)(Abs(EntierCell)), SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=EntierCell).Row
  If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function

[laurent_ott]

Bonjour.
Je n'ai peut-être pas bien compris la question, mais s'il s'agit d'intervenir dans Access depuis Excel, voir cette documentation :
Manipuler les données des bases Access depuis Excel

Cordialement.

[Thumb down]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub MajAccess(ID As String) 'procédure personnalisé avec passage de parametre ID!
 'On Error Resume Next
Application.ScreenUpdating = False
On Error GoTo ErrorUpdate
Dim Row As Integer
Row = ThisWorkbook.Sheets("Parametres").Range("B17")
 
 
Dim Cn As New ADODB.Connection, Rs As New ADODB.Recordset, SQL As String, I As Integer, C As Integer 'Déclaration des variable
'je séléctionne tous les champs de la table Feuil1$ don ID est égale au parmetre passé à la procédure MajXls ThisWorkbook.Sheets("Feuil1").Range("J1")
SQL = "select * from [DATA] WHERE ID=" & ID
 
    With Cn '==>Open connection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & ThisWorkbook.Sheets("Parametres").Range("B3")
        .Open
      Rs.Open SQL, Cn, 1, 3 'execution de la requête
 
        With ThisWorkbook.Sheets("DATA")
            I = SerchXls(.Range("BR:BR"), .Range("BR1"), ID, True) 'Recherche la lige de ID
            If I = 0 Then Cn.Close: MsgBox "ID pas trouvé ! Bug": Exit Sub  'ID pas trouvé
            'S'il s'agit d'une nouvelle ligne alors cération d'un nouvelle ligne'Rs.AddNew
            If ThisWorkbook.Sheets("Parametres").Range("VerrouClient") = "New" Then
                MsgBox "Le nouveau budget va être ajouté !", vbInformation, "Informations"
                Rs.AddNew
            End If
            '
                'If Rs.EOF Then Rs.AddNew: MsgBox "Les données du nouveau budget vont être sauvgardées !", vbInformation, "Informations"  'Si la requête ne touve pas ID alors nouvel enregistrement
                For C = 0 To Rs.Fields.Count - 1
                    Rs.Fields(.Cells(1, "A").Offset(0, C).Value) = .Cells(I, "A").Offset(0, C).Value
                    'Rs.Fields(Trim(.Cells(1, "A").Offset(0, C).Value)) = .Cells(I, "A").Offset(0, C).Value 'charges les valeur dans le recordset
                Next
                Rs.Update 'met à jour le record set
        End With
        .Close
    End With
 
'MsgBox "Les données du client ont bien été sauvgardées !", vbInformation, "Informations"
 
 
Exit Sub
ErrorUpdate:
    On Error Resume Next
    MsgBox "Les données n'ont pas pu être sauvgardées en raison d'un problème technique !", vbCritical, "Informations"
End Sub

[Pierre Fauconnier]

Salut.

J'ai modélisé les échanges Excel / Access dans 4 billets. Tu peux trouver le premier ici et suivre la lecture pour retrouver les suivants.

[jfbonvin]

Bonjour à tous,

Je vois à l'instant vos réponses.
Un grand merci pour votre aide

[jfbonvin]

Le code de Thumb down marche parfaitement. Merci !

J'ai encore une question !
Et si je voulais mettre à jour l'ensemble de mon tableau Excel vers Access. Quel serai le code si le Tableau s'appelle Listes tout comme la table Access ?

Merci d'avance pour vos retours

[TSAFACK-M]

Le code de Thumb down marche parfaitement. Merci !

J'ai encore une question !
Et si je voulais mettre à jour l'ensemble de mon tableau Excel vers Access. Quel serai le code si le Tableau s'appelle Listes tout comme la table Access ?

Merci d'avance pour vos retours

Bonjour,

Pour mettre à jour une table Access à des données d'une table Excel, il faut combiner l'instruction INSERT INTO ET SELECT dans un meme Script SQL

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
       SQL= "INSERT INTO MaTableDestination(Champ1, Champ2, Champ2, Champ4, Champ5, Champ6, Champ7, Champ8) " _
            & "SELECT Champ1, Champ2, Champ3, Champ4, Champ5, Champ6, Champ7, Champ8 FROM MaTableSource;"

Puis Exécuter via la methode Ado et le tout est joué !

[Thumb down]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
 Sub MajToutAccess() 
Application.ScreenUpdating = False
On Error GoTo ErrorUpdate
Dim Cn As New ADODB.Connection, Rs As New ADODB.Recordset, SQL As String, I As Integer, C As Integer 'Déclaration des variable
'je séléctionne tous les champs de la table Feuil1$ don ID est égale au parmetre passé à la procédure MajXls ThisWorkbook.Sheets("Feuil1").Range("J1")
SQL = "select * from [DATA]"
 
    With Cn '==>Open connection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
        & ThisWorkbook.Sheets("Parametres").Range("B3")
        .Open
        Rs.Open SQL, Cn, 1, 3 'execution de la requête
 
    With ThisWorkbook.Sheets("DATA")
        For I = 2 To .Cells(.Cells.Rows.Count, "BR").End(xlUp).Row
           Rs.Filter = "ID='" & .Cells(I, "BR") & "'"
            If Rs.EOF Then Rs.AddNew
 
            'If Rs.EOF Then Rs.AddNew: MsgBox "Les données du nouveau budget vont être sauvgardées !", vbInformation, "Informations"  'Si la requête ne touve pas ID alors nouvel enregistrement
            For C = 0 To Rs.Fields.Count - 1
            Debug.Print .Cells(1, "A").Offset(0, C).Value, .Cells(I, "A").Offset(0, C).Value
                Rs.Fields(.Cells(1, "A").Offset(0, C).Value) = Trim("" & .Cells(I, "A").Offset(0, C).Value)
            Next
            Rs.Update 'met à jour le record set
        Next
        End With
        .Close
    End With
 
MsgBox "Les données du client ont bien été sauvgardées !", vbInformation, "Informations"
 
 
Exit Sub
ErrorUpdate:
    On Error Resume Next
    MsgBox "Les données n'ont pas pu être sauvgardées en raison d'un problème technique !", vbCritical, "Informations"
End Sub