Liens Access/Excel

Attachement Excel/Access
Lecture DAO
Saisie Formulaire
Interrogation DAO
Scrutation Table
Lecture ADO
Mise à jour ADO
Création ADO

Attachement à une base Access

-La commande Données/Données externes/Créer une requête permet de s'attacher à une BD access
-Un clic droit /propriétés de la plage permet de demander une maj à l'ouverture du classeur
-La présentation est conservée.
-On peut insérer des colonnes avec formules.

Avec le code ci dessous, on peut créer ou supprimer un attachement.

Sub Attache()
  ChDir ActiveWorkbook.Path
  sqlChaine = "select * from client"
  RepAppli = ActiveWorkbook.Path
  ChaineConn = "ODBC;DSN=MS Access Database;DBQ=" & RepAppli & "\Access2000.mdb"
  ActiveSheet.QueryTables.Add(Connection:=ChaineConn, Destination:=Range("A1"), Sql:=sqlChaine).Refresh
End Sub

Sub sup()
Sheets(1).Range("A1:C1000").Delete Shift:=xlShiftToLeft
End Sub

Lecture table Access avec DAO

La table access Client contient:
-Un champ nom_client
-Un champ ville

La base Access.mdb doit exister et être dans le même répertoire

Sub LitAccess()
  'cocher Microsoft DAO 3.6 dans Outils/Références
  Dim bd As Database
  Dim rs As Recordset
  repertoire = ThisWorkbook.Path & "\"
  Set bd = OpenDatabase(repertoire & "access2000.mdb")
  Set rs = bd.OpenRecordset("Select * From Client")
  'Set rs = bd.OpenRecordset("select count(*) as nb from client")
' MsgBox rs("nb")
' rs.Close
  Set rs = bd.OpenRecordset("Select * From Client")
  i = 2
  Do While Not rs.EOF
    Cells(i, 1) = rs!Nom_Client
    Cells(i, 2) = rs!Ville
    Cells(i, 3) = rs!Salaire
    rs.MoveNext
    i = i + 1
  Loop
End Sub

Saisie dans un formulaire

La table access Client contient:
-Un champ nom_client
-Un champ ville
-Un champ Salaire

La base Access.mdb doit exister et être dans le même répertoire

Private Sub b_ok_Click()
  'cocher Microsoft DAO 3.6 dans Outils/Références
  Dim bd As Database
  Dim dt As Recordset
  Set bd = OpenDatabase(ActiveWorkbook.Path & "\access2000.mdb")
  Set rs = bd.OpenRecordset("client")
  If Me.nom_client = "" Then
     MsgBox "Saisir un nom!"
     Me.nom_client.SetFocus
     Exit Sub
  End If
  rs.AddNew
  rs!nom_client = Me.nom_client
  rs!ville = Me.ville
  rs!salaire = CDbl(Me.salaire)
  rs.Update
  rs.Close
  bd.Close
  Me.nom_client = Null
  Me.ville = Null
  Me.salaire = Null
  Me.nom_client.SetFocus
End Sub

Interrogation table Access DAO

La table access Client contient:
-Un champ nom_client
-Un champ ville

Private Sub choix_Change()
  'cocher Microsoft DAO 3.6 dans Outils/Références
  Dim bd As Database
  Dim rs As Recordset
  Set bd = OpenDatabase(ActiveWorkbook.Path & "\access2000.mdb")
  Sql = "Select * From Client WHERE nom_client='" & Me.choix & "'"
  Set rs = bd.OpenRecordset(Sql)
  Me.Ville = rs!Ville
  Me.Salaire = rs!Salaire
  rs.Close
  bd.Close
End Sub

Private Sub UserForm_Initialize()
  'cocher Microsoft DAO 3.6 dans Outils/Références
  Dim bd As Database
  Dim rs As Recordset
  Set bd = OpenDatabase(ActiveWorkbook.Path & "\access2000.mdb")
  Set rs = bd.OpenRecordset("Select * From Client Order By Nom_Client")
  Do While Not rs.EOF
    Me.choix.AddItem rs!nom_client
    rs.MoveNext
  Loop
End Sub

Scrutation d'une table Access

On scrute une BD Access pour savoir si des enregistrements ont étés ajoutés

Dim temps
  Sub ScruteAccess()
  'cocher Microsoft DAO 3.6 dans Outils/Références
  Dim bd As Database
  Dim rs As Recordset
  Set bd = OpenDatabase(ActiveWorkbook.Path & "\access2000.mdb")
  Set rs = bd.OpenRecordset("select count(*) as NbEnreg from client")
  If rs("NbEnreg") <> [B1] Then
     MsgBox "Modif Access"
  End If
  [B1] = rs("NbEnreg")
  rs.Close
  temps = Now + TimeValue("00:00:05")
  Application.OnTime EarliestTime:=temps, Procedure:="scruteAccess"
End Sub

Sub auto_close()
On Error Resume Next
Application.OnTime temps, Procedure:="majHeure", Schedule:=False
End Sub

Lecture Access ADO

Sub LectureAccess()
  'Microsoft ActivexDataObject 2.8 Library
  repertoire = ThisWorkbook.Path & "\"
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
  Set rs = cnn.Execute("SELECT * FROM Client ORDER BY nom_client")
  Range("A2").CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Sub LectureAccess2()
  repertoire = ThisWorkbook.Path & "\"
  Dim rs As New ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
  rs.Open "SELECT * FROM client ORDER BY nom_client", cnn
  Do While Not rs.EOF
    MsgBox rs!Nom_Client
    rs.MoveNext
  Loop
  rs.Close
  cnn.Close
End Sub

Connaître les noms et les types de champ

Sub LectureAccess()
  'Microsoft ActivexDataObject 2.8 Library dans outils/référence
  repertoire = ThisWorkbook.Path & "\"
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
  Set rs = cnn.Execute("SELECT * FROM Client")
  For i = 0 To rs.Fields.Count - 1
    Cells(i + 2, 1) = rs(i).Name
    Cells(i + 2, 2) = rs(i).Type
  Next i
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Compter le nb d'enregistrements vérifiant une condition

Sub LectureAccess3()
  ChDir ActiveWorkbook.Path
  Dim rs As New ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=Access2000.mdb"
  rs.Open "SELECT count(*) AS Nb FROM client where ville='paris' ", cnn
  Cells(1, 5) = rs("Nb")
  rs.Close
  cnn.Close
End Sub

Mise à jour ADO

Sub UpdateAccess()
  ChDir ActiveWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=Access2000.mdb"
  Sql = "UPDATE client SET Nom_Client=Ucase(Nom_Client) "
  cnn.Execute Sql
  cnn.Close
End Sub

Sub UpdateAccessADO2()
   ChDir ActiveWorkbook.Path
   Set cnn = New ADODB.Connection
   cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=Access2000.mdb"
   Sql = "UPDATE client SET Salaire=3500 WHERE Nom_Client='Dupont'"
   cnn.Execute Sql
   cnn.Close
End Sub

Pour mettre à jour le salaire et la ville de Dupont:

UPDATE client SET Salaire=5500, Ville='Bordeaux' WHERE Nom_Client='Dupont'

Sub UpdateAccessADO3()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
  msalaire = 5500
  mville = "Bordeaux"
  mnom = "Dupont"
  Sql = "UPDATE client SET Salaire=" & msalaire & ", Ville='" & mville & "' WHERE Nom_Client='" & mnom & "'"
  [A1] = Sql
  MsgBox Sql
  cnn.Execute Sql
  cnn.Close
End Sub

Création Access ADO

Private Sub B_ok_Click()
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=Access2000.mdb"
  Sql = "INSERT INTO Client (Nom_client,ville,salaire) VALUES('" & Me.Nom_Client & "','" & _
  Me.Ville & "'," & CDbl(Me.Salaire) & ")"
  cnn.Execute Sql
  cnn.Close
  Set cnn = Nothing
End Sub

  ChDir ActiveWorkbook.Path
  Dim rs As New ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=Access2000.mdb"
  rs.Open "client", cnn, adOpenDynamic, adLockOptimistic
  rs.AddNew
  rs!Nom_Client = Me.Nom_Client
  rs!Ville = Me.Ville
  rs.Update
  rs.Close
  cnn.Close

Interrogation formulaire ADO

Private Sub UserForm_Initialize()
  rep = ThisWorkbook.Path
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & rep & "\Access2000.mdb"
  Set rs = cnn.Execute("SELECT nom_client FROM Client ORDER BY nom_client")
  Me.Choix.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Private Sub Choix_Change()
  rep = ThisWorkbook.Path
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & rep & "\Access2000.mdb"
  Sql = "SELECT * FROM Client WHERE nom_client='" & Me.Choix & "'"
  Set rs = cnn.Execute(Sql)
  Me.Ville = rs!Ville
  Me.Salaire = rs!Salaire
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Formulaire photo Access

Photo.mdb

Exemples

Excel Access Synthèse

GraphesAccess