Piloter une base Access par ActiveX Data Objects

Sub exportDonnees_Excel_Vers_Access()
'ajouter un enregistrement dans une table Access
'necessite d'activer la reference Microsoft ActiveX Data Objects x.x Library
Dim Conn As New ADODB.Connection
Dim rsT As New ADODB.Recordset
Dim maTable As String

maTable = 'Table1'

With Conn
.Provider = 'Microsoft.JET.OLEDB.4.0'
.Open 'C:\\Documents and Settings\\michel\\Excel\\MaBase_V01.mdb'
End With
        
With rsT
.ActiveConnection = Conn
.Open maTable, LockType:=adLockOptimistic
End With
    
With rsT
.AddNew
.Fields('Nom').Value = Range('A1')
.Fields('PrixUnit').Value = Range('B1')
.Fields('Matricule').Value = Range('C1')
.Update
End With
    
rsT.Close
Conn.Close
End Sub

Sub suppressionEnregistrementTable()
Dim Cn As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim Requete As String, maTable As String, Donnee As String
Dim Valeur As Integer

Set Cn = New ADODB.Connection
Set Rst = New ADODB.Recordset

Cn.Provider = 'Microsoft.Jet.Oledb.4.0'
Cn.ConnectionString = 'C:\\MaBase_V02.mdb'
Cn.Open

maTable = 'LesPoints'
'
'****pour des valeurs numeriques ****
'suppression des enregistrements si le champ 'nbPoints' est égal à 5 , dans la table 'lesPoints'
'
'Valeur = 5
'Requete = 'DELETE * FROM ' & maTable & ' WHERE NbPoints=' & Valeur
'
'**** pour des données texte ********
'suppression des lignes si le champ 'Nom' est égal à 'Nom03' , dans la table 'lesPoints'
Donnee = 'Nom03'
Requete = 'DELETE * FROM ' & maTable & ' WHERE [Nom]='' & Donnee & '''
'************************************
Cn.Execute Requete

Cn.Close
End Sub

Sub AjoutColonne_TableAccessExistante()
Dim Cnn As New ADODB.Connection
Dim Cat As New ADOX.Catalog
Dim NouvelleColonne As New ADOX.Column
Dim Rst As New Recordset
Dim Reponse As String, Fichier As String
    
On Error GoTo Fin
    
Fichier = 'C:\\MaBase_V02.mdb'
Cnn.Open 'Provider='Microsoft.Jet.OLEDB.4.0';' & _
'Data Source= '' & Fichier & '';'
    
Set Cat.ActiveConnection = Cnn
'paramétrage colonne
NouvelleColonne.Name = 'NouveauChamp'
NouvelleColonne.Type = adChar
NouvelleColonne.DefinedSize = 50
NouvelleColonne.Attributes = adColNullable
Cat.Tables('LesPoints').Columns.Append NouvelleColonne.Name, adWChar, 50
    
Rst.Open 'LesPoints', Cnn, adOpenKeyset, adLockOptimistic, adCmdTable
    
Fin:
Cnn.Close
Set Rst = Nothing
Set Cat = Nothing
Set NouvelleColonne = Nothing
Set Cnn = Nothing
End Sub

Sub Tri_Croissant_Champ_BaseAccess()
'effectuer un tri croissant dans la colonne 'Nom' de la table 'LesPoints'
Dim Cnn As New ADODB.Connection
Dim Cat As New ADOX.Catalog
Dim indexTri As New ADOX.Index
Dim Rst As New ADODB.Recordset
Dim Fichier As String
    
On Error GoTo Fin

Fichier = 'C:\\MaBase_V03.mdb'
Cnn.Open 'Provider='Microsoft.Jet.OLEDB.4.0';' & _
'Data Source='' & Fichier & '';'

Set Cat.ActiveConnection = Cnn

With indexTri
.Columns.Append 'Nom'
.Columns('Nom').SortOrder = adSortAscending 'tri croissant
.Name = 'Ascending'
'.Columns('Nom').SortOrder = adSortDescending 'pour les tris décroissants
'.Name = 'Descending'
.IndexNulls = adIndexNullsAllow
End With

'ajout d'un index pour la table 'LesPoints'
'attention : renvoie une erreur si un index existe déja
Cat.Tables('LesPoints').Indexes.Append indexTri
    
Rst.Index = indexTri.Name
Rst.Open 'LesPoints', Cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
        
'import dansd la feuille Excel des données triées
Feuil1.Range('A1').CopyFromRecordset Rst

Cat.Tables('LesPoints').Indexes.Delete indexTri.Name 'suppression index
    
Fin:
Cnn.Close
Set Cat = Nothing
Set indexTri = Nothing
Set Rst = Nothing
Set Cnn = Nothing
End Sub

Sub Export_VersNouvelleFeuille_ClasseurExcelFerme()
'transférer la feuille 'devis' dans un nouvel onglet d'un classeur fermé
Dim oRS As ADODB.Recordset
Dim oConn As ADODB.Connection
Dim maFeuille As String, prepaTable As String
Dim j As Integer, i As Integer

'nom(sans espace!) de la feuille Excel qui va etre créée dans le classeur fermé
maFeuille = 'ArchiveDevis002'

Set oConn = New ADODB.Connection
oConn.Open 'Provider=Microsoft.Jet.OLEDB.4.0;' & _
'Data Source=C:\\Classeur1_Fermé.xls;' & _
'Extended Properties=''Excel 8.0;HDR=NO;'''
    
For i = 1 To 10 'nombre de colonnes à transférer
'paramétrage entêtes de colonnes et types de données
prepaTable = prepaTable & 'Colonne' & i & ' Memo ,'  'adapter les types de données
Next i

prepaTable = Left(prepaTable, Len(prepaTable) - 1)
'creation nouvelle Feuille Excel
oConn.Execute 'create table ' & maFeuille & '(' & prepaTable & ')'

Set oRS = New ADODB.Recordset
oRS.Open 'Select * from ' & maFeuille, oConn, adOpenKeyset, adLockOptimistic
    
For j = 1 To 40 'nombre de lignes à transferer
oRS.AddNew
For i = 1 To 10 'nombre de colonnes à transférer
oRS.Fields(i - 1) = ActiveSheet.Cells(j, i)
Next i
RS.Update
Next j
    
oRS.Close
oConn.Close
End Sub

Sub test()
Dim Conn As ADODB.Connection
Dim rsT As ADODB.Recordset
Dim fld As ADODB.Field

Set Conn = New ADODB.Connection
With Conn
' Définition du fournisseur OleDB pour la connexion
.Provider = 'Microsoft.JET.OLEDB.4.0'
' Ouverture d'une connexion
.Open ThisWorkbook.Path & '\\MaBase_V01.mdb'
End With

Set rsT = New ADODB.Recordset
'table nommée 'maTable'
rsT.Open 'maTable', Conn, adOpenKeyset, adLockOptimistic

With rsT
.MoveFirst
'recherche la valeur de la cellule A1 dans champ 'Matricule'
.Find ('Matricule=' & Cells(1, 1))

'quand la valeur est trouvée , on modifie le champ 'leChamp'
.Fields('leChamp') = 'xxxx'
.Update
End With

Conn.Close
End Sub