ADO

Accueil


Import d'un classeur fermé
Lecture classeur fermé avec CopyFromRecordset
Lecture classeur fermé avec GetRows
Lecture d'une cellule avec une fonction
SommeSi avec classeur fermé
Existence d'un code dans un classeur fermé
Modification d'un enregistrement
Ajout d'un enregistrement
Menu déroulant avec articles dans un fichier fermé
Listes en cascade 2 niveaux dans un classeur fermé
Menus en cascade 3 niveaux avec choix de la feuille
Menus en cascade 4 niveaux avec choix du fichier et de la feuille
Eléments communs à 2 listes dans classeurs fermés
Lignes communes à 2 BD
Formulaire BD Access
Données/Validation avec Access
Autres méthodes pour lire dans un classeur fermé
Noms de champ d'une BD
Listes Cascade ADO
Modification d'une cellule dans un classeur fermé
ADO Ajout
ListeSansDoublons
Totalisation
Comptage 2 critères
Nombre de commandes distinctes
Lecture Access ADO
Mise à Jour ADO Access
Liste des items sans doublons
Recherche dans table externe
Liste des feuilles d'un classeur fermé
Le langage SQL
Fonction guillemet

Import d'un classeur fermé avec ADO

-ADO-

Un fichier ADOsource.Xls contient

Récupération d'un champ dans le tableur avec CopyFromRecordset

Sub RecupTableur2()
 ' Microsoft ActiveX DataObject doit être coché
 Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path
  fichier = "AdoSource.xls"
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & répertoire & "\" & fichier & ";Extended     Properties=""Excel 8.0;HDR=No;"";"
  Set rs = cnn.Execute("[Feuil1$A1:C100]")
  [A1].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Avec HDR=Yes, on ne récupère pas les titres de la BD.

[A2].CopyFromRecordset rs

Récupération d'un champ dans le tableur avec GetRows

Sub RecupChampGetRows()
  ' Microsoft ActiveX DataObject doit être coché
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  fichier = "AdoSource.xls"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & répertoire & fichier ' Fichier .xls
  Set rs = cnn.Execute("[A1:C100]")
  a = rs.GetRows
  [A2].Resize(3, UBound(a) + 1) = Application.Transpose(a)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

On récupère:

Pour lire dans un fichier .xlsm Excel2007

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & répertoire & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"

Récupération d'un champ dans un tableau Tbl() avec GetRows

Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & ThisWorkbook.Path & "\" & "ADOsource.xls"
Set rs = cnn.Execute("[A1:C4]")
Tbl = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
MsgBox Tbl(0, 0)
MsgBox Tbl(0, 1)
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing

Donne le nombre de lignes d'une BD

Sub CompteLignes()
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & ThisWorkbook.Path & "\" &     "ADOsource.xls"
   Set rs = cnn.Execute("SELECT count(*) as nb FROM [Feuil1$A1:C1000]")
   n = rs("nb")
   MsgBox n
   rs.Close
   cnn.Close
   Set rs = Nothing
   Set cnn = Nothing
End Sub

Fonction pour lire une cellule

Pour récupérer la cellule A4 de ADOSource.xls, =LitUneCellule(D2;D3;D4;D5)

LitEcritCelluleADO

Function LitUneCellule(repertoire As String, fichier As String, feuille As String, cellule As String)
  'Microsoft ActiveX DataObject 2.8 doit être coché
  Application.Volatile
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & repertoire & "\" & fichier & _
         ";Extended Properties=""Excel 8.0;HDR=No;"";"
  Set rs = cnn.Execute("SELECT * FROM [" & feuille & "$" & cellule & ":" & cellule & "]")
  LitUneCellule = rs(0)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Function

La fonction ci dessus peut ausi être appelée par VBA

Sub Lit()
  x = LitUneCellule("c:\mesdoc\excelmacronouveau\1001exemples", "ADOsource.xls", "feuil1", "A4")
  MsgBox x
End Sub

SommeSi avec classeur fermé

=sommesi("classeur1.xlsx";"titre2";"pal";"titre4")

Function SommeSi(fichier, champCrit, critere, champSomme)
'Microsoft ActiveX 2.8 doit être coché
Dim Cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
chemin = ActiveWorkbook.Path & "\" & fichier
chaineConnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & chemin & ";HDR=Yes';"
Cnn.Open chaineConnect
Sql = "SELECT SUM(" & champSomme & ") From [maBD] where " & champCrit & "='" & critere & "'"
rs.Open Sql, Cnn
SommeSi = rs(0)
rs.Close
Cnn.Close
End Function

SommeSiADO
Classeur1.xlsx

Modification d'une cellule

Sub Ecrit()
  Call ModifieUneCellule("c:\mesdoc\excelmacronouveau\1001exemples", "ADOsource.xls", "feuil1", "A4", "totox")
End Sub

Sub ModifieUneCellule(repertoire As String, fichier As String, feuille As String, cellule As String, NouvelleValeur)
  'Microsoft ActiveX DataObject 2.8 doit être coché
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & repertoire & "\" & fichier & _
      ";Extended Properties=""Excel 8.0;HDR=No;"";"
     Sql = "SELECT * FROM [" & feuille & "$" & cellule & ":" & cellule & "]"
     Set rs = New ADODB.Recordset
     rs.Open Sql, cnn, adOpenDynamic, adLockOptimistic
     rs(0).Value = NouvelleValeur
     rs.Update
     rs.Close
     cnn.Close
     Set rs = Nothing
     Set cnn = Nothing
End Sub

Récupération dans le tableur avec SQL

Sub ImporteBD()
  'Microsoft ActiveX DataObject doit être coché
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & repertoire & "ADOsource.xls"
  Set rs = cnn.Execute("SELECT nom,prenom,salaire FROM [Feuil1$A1:C1000]")
  [A2].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Dans ADOsource.xls, un nom de champ MaBD =Feuil1!$A$1:$C$500 a été défini.

Sub RecupTableurSQL()
  'Microsoft ActiveX DataObject doit être coché
  répertoire = ThisWorkbook.Path & "\"
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & épertoire & "ADOsource.xls"
  Set rs = cnn.Execute("SELECT nom,Prenom,Salaire FROM MaBD where nom<>''")
  [A2].CopyFromRecordset rs
End Sub

Pour effectuer une sélection sur un champ Date, le jour et le mois doivent être inversés en Excel 2003

Set rs = cnn.Execute("SELECT nom,Prenom,Salaire,Naissance FROM MaBD where Naissance=#17/12/1980#)

Formulaire alimenté par une base Access

Private Sub UserForm_Initialize()
  'Microsoft Data Object 2.8 doit être coché
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
  Set rs = cnn.Execute("SELECT nom_client FROM client Order By nom_client")
  Me.ComboBox1.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Existence d'un code dans un fichier fermé

ADOInterro
Article.xls

Sub ChercheCodeFichierFermé()
  'Microsoft ActiveX Data Object 2.8 doit être activé
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  moncode = "Art2"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "Article.xls"
  Set rs = cnn.Execute("SELECT code FROM BD WHERE code='" & moncode & "'")
  If rs.EOF() Then
      MsgBox moncode & " Inconnu"
   Else
      MsgBox moncode & " Trouvé!"
   End If
   cnn.Close
   Set rs = Nothing
   Set cnn = Nothing
End Sub

Si le code cherché existe plusieurs fois, nous affichons dans un ListBox tous les enregistrements pour le code saisi dans TextBox1:

ADOInterro2

Private Sub CommandButton1_Click()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  moncode = Me.TextBox1
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "Article.xls"
  Set rs = cnn.Execute("SELECT * FROM BD WHERE code='" & moncode & "'")
  Me.ListBox1.Clear
  If rs.EOF() Then
     Me.TextBox2 = "Inconnu"
  Else
     Me.TextBox2 = ""
     i = 0
     Do While Not rs.EOF
       Me.ListBox1.AddItem rs(0)
       Me.ListBox1.List(i, 1) = rs(1)
       Me.ListBox1.List(i, 2) = rs(2)
       rs.MoveNext
       i = i + 1
    Loop
  End If
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Version avec choix dans un ComboBox

ADOInterro3
Article3

Private Sub UserForm_Initialize()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "Article3.xls"
  Set rs = cnn.Execute("SELECT DISTINCT designation FROM BD WHERE designation<>'' ORDER BY designation")
  a = Application.Transpose(rs.GetRows)
  Me.ComboBox1.List = a
End Sub

Private Sub ComboBox1_Change()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  moncode = Me.ComboBox1
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "Article3.xls"
  Set rs = cnn.Execute("SELECT * FROM BD WHERE designation='" & moncode & "'")
  Me.ListBox1.Clear
  i = 0 
  Do While Not rs.EOF
     Me.ListBox1.AddItem rs(0)
     Me.ListBox1.List(i, 1) = rs(1)
     Me.ListBox1.List(i, 2) = rs(2)
     rs.MoveNext
     i = i + 1
  Loop
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Version avec modification & création d'enregistrements

Un formulaire permet de consulter et de modifier une BD.

ADOInterro4
Article4

Un autre formulaire permet de créer de nouveaux enregistrements.
Un nouveau numéro de référence est crée..

Private Sub B_création_Click()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & repertoire & fichier & ";Extended Properties=Excel 8.0;"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * FROM BD", cnn, adOpenDynamic, adLockOptimistic
  rs.MoveLast
  B_raz_Click
  Me.TextBox7 = "Ref" & Format(Val(Right(rs(0), 3)) + 1, "000")
  Me.TextBox5.SetFocus
  Me.B_validation.Locked = False
End Sub

Modification enregistrement

Un fichier ADOsource.Xls contient

Sub ModifEnregistrement()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  fichier = repertoire & "ADOsource.xls"
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & fichier & ";Extended Properties=Excel 8.0;"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * from [Feuil1$A1:C1000] WHERE nom='Toto'", cnn, adOpenDynamic, adLockOptimistic
  rs(1).Value = "zzz"
  rs.Update
  rs.Close
  cnn.Close
End Sub

Ajout d'un enregistrement en fin de fichier

Sub AjoutEnregistrement()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  fichier = repertoire & "ADOsource.xls"
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & fichier & ";Extended Properties=Excel 8.0;"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * from [Feuil1$A1:C1000]", cnn, adOpenDynamic, adLockOptimistic
  rs.AddNew
  rs(0).Value = "Durand"
  rs(1).Value = "Jean"
  rs(2).Value = 3400
  rs.Update
  rs.Close
  cnn.Close
End Sub

ou

Sub ajout()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  fichier = repertoire & "ADOsource.xls"
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & fichier & ";Extended Properties=Excel 8.0;"
  Sql = "INSERT INTO [Feuil1$A1:C1000] (Nom,Prenom,salaire) Values('titi','jean',4000)"
  cnn.Execute Sql
  cnn.Close
End Sub

Recherche d'un Item

Sub essai()
  ' Microsoft ActiveX DataObject doit être coché
  ' Champ nommé MaBD avec lignes vides
  Set cnn = New ADODB.Connection
  nomcherche = "Martin"
  repertoire = ThisWorkbook.Path & "\"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
  repertoire & "ADOsource.xls"
  Sql = "SELECT Prenom,salaire FROM MaBD WHERE nom='" & nomcherche & "'"
  Set rs = cnn.Execute(Sql)
  MsgBox rs("prenom")
  MsgBox rs("salaire")
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Autre méthode

repertoire = ThisWorkbook.Path & "/"
nomcherche = "Besnard"
[B1].Formula = "=vlookup(" & Chr(34) & nomcherche & Chr(34) & ",'" & repertoire & "ADOsource.XLS'!MaBD,2,false)"
temp = [B1]
MsgBox temp

Récupération des enregistrements dans un tableau

Sub RecupTableau()
  ' Microsoft ActiveX DataObject doit être coché
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
  ThisWorkbook.Path & "\" & "ADOsource.xls"
  Set rs = cnn.Execute("[A1:C4]")
  Tbl = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
  MsgBox Tbl(0, 0)
  MsgBox Tbl(0, 1)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Nombre d'enregistrements

Sub NbEnregistrements()
  repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
  repertoire & "ADOsource.xls"
  Set rs = cnn.Execute("SELECT count(*) as NbLignes FROM [Feuil1$A1:C1000]")
  x = rs("nbLignes")
  MsgBox x
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Récupération dans un formulaire avec SQL

Private Sub UserForm_Initialize()
  'Microsoft ActiveX DataObject doit être coché
  ' Champ nommé MaBD avec lignes vides
 
repertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
      repertoire & "ADOsource.xls"
  Set rs = cnn.Execute("SELECT nom,Prenom FROM MaBD WHERE nom<>'' Order By nom")
  Me.ListBox1.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Autre exemple

Dans un fichier Fichier1.xls, on alimente Combobox1 avec un champ d'un fichier fermé Fichier2.xls.

Fichier.zip

Sub auto_open()
  'Microsoft activeX dataobject doit être coché
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & "fichier2.xls"
  Set rs = cnn.Execute("SELECT planètes FROM planètes WHERE planètes<>''")
  Sheets(1).ComboBox1.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Saisie des codes article avec articles dans un fichier fermé (ADO)

Le menu déroulant est alimenté par ADO dans le classeur fermé ARTICLE.XLS.

DVClasseurFermé

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A12:A25], Target) Is Nothing And Target.Count = 1 Then
    UserForm1.Left = 100 + Target.Left
    UserForm1.Top = 100 + Target.Top
    UserForm1.Show
  End If
End Sub

Private Sub UserForm_Initialize()
  'Microsoft ActiveX Data Object 2.8 doit être activé
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "Article.xls"
  Set rs = cnn.Execute("SELECT code,designation,prix FROM BD WHERE code<>''")
  Me.ComboBox1.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  ActiveCell = Me.ComboBox1
  ActiveCell.Offset(, 1) = Me.ComboBox1.Column(1)
  ActiveCell.Offset(, 2) = Me.ComboBox1.Column(2)
  Unload Me
End Sub

Listes en cascade avec classeur fermé (ADO)

ListesCascadeADO

Dim répertoire
Dim fichier
Private Sub UserForm_Initialize()
  'Microsoft ActiveX Data Object 2.8 doit être activé
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  fichier = "continent.xls"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & fichier
  Set rs = cnn.Execute("SELECT continent FROM BD WHERE continent<>''Group By continent")
  'Set rs = cnn.Execute("SELECT DISTINCT continent FROM BD WHERE continent<>''")
  Me.ComboBox1.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & fichier
  Set rs = cnn.Execute("SELECT pays FROM BD WHERE continent='" & Me.ComboBox1 & "'")
  Me.ComboBox2.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Me.ComboBox2.SetFocus
  SendKeys "{F4}"
End Sub

Private Sub ComboBox2_Change()
  ActiveCell = Me.ComboBox1
  ActiveCell.Offset(, 1) = Me.ComboBox2
  Unload Me
End Sub

Choix d'un produit et d'un fournisseur dans un fichier fermé(ADO)

ADOFourn

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([b7:b7], Target) Is Nothing And Target.Count = 1 Then
     UserForm1.Left = 100 + Target.Left
     UserForm1.Top = 100 + Target.Top
     UserForm1.Show
   End If
End Sub

Dim répertoire
Dim fichier
Private Sub UserForm_Initialize()
  'Microsoft ActiveX Data Object 2.8 doit être activé
   Dim rs As ADODB.Recordset
   Set cnn = New ADODB.Connection
   répertoire = ThisWorkbook.Path & "\"
   fichier = "BDD MP.xls"
   cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & fichier
   Set rs = cnn.Execute("SELECT [Code Produit],[Désignation MP] FROM BD WHERE [Code Produit]<>'' group BY [Code Produit],[Désignation MP]")
   Me.ComboBox1.List = Application.Transpose(rs.GetRows)
   rs.Close
   cnn.Close
   Set rs = Nothing
   Set cnn = Nothing
   SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & fichier
  Set rs = cnn.Execute("SELECT [Désignation fournisseur] FROM BD WHERE [Code Produit]='" & Me.ComboBox1 & "'")
  Me.ComboBox2.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Me.ComboBox2.SetFocus
End Sub

Private Sub ComboBox2_Change()
  ActiveCell = Me.ComboBox1
  ActiveCell.Offset(1) = Me.ComboBox2
  ActiveCell.Offset(2) = Me.ComboBox1.Column(1)
  Unload Me
End Sub)

Autre exemple

FormCascadeADO
SourceADO

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  ' Microsoft ActiveX DataObject doit être coché
  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path & "\"
  fichier = "RisqueAdoSource.xls"
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & répertoire & fichier ' Fichier .xls
  Set rs = cnn.Execute("[BD$A1:AG100]")
  f.[A1].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Me.ListBox1.List = Application.Transpose(f.[A1].Resize(, Application.CountA(f.[A1:IV1])))
End Sub

Private Sub ListBox1_Click()
  col = Me.ListBox1.ListIndex + 1
  i = 2
  Me.ListBox2.Clear
  Do While f.Cells(i, col) <> ""
    Me.ListBox2.AddItem f.Cells(i, col)
    i = i + 1
  Loop
End Sub

Menu 3 niveaux avec choix de la feuille (ADO)

ADORecette


Dim Fich
Private Sub UserForm_Initialize()
  Fich = "LISTES_RECETTES.xls"
  répertoire = ThisWorkbook.Path & "\" ' adapter
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & Fich
  Set cata.ActiveConnection = cnn
  For Each t In cata.Tables
    If Right(t.Name, 1) = "$" Then Me.ComboBoxchoix_onglets.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  Me.ComboBoxchoix_onglets.ListIndex = 0
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBoxchoix_onglets_click()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & Fich
  Set rs = cnn.Execute("SELECT intitulé FROM [" & _
  Me.ComboBoxchoix_onglets & "$A1:C1000] WHERE intitulé<>'' GROUP BY intitulé")
  Me.ComboBoxintitulé.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Me.ComboBoxintitulé.ListIndex = -1
  Me.ComboBoxrecette.ListIndex = -1
End Sub

Private Sub ComboBoxintitulé_click()
  Me.ComboBoxrecette.ListIndex = -1
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & Fich
  Set rs = cnn.Execute("SELECT recette FROM [" & Me.ComboBoxchoix_onglets & "$A1:C1000] WHERE intitulé='"       & Me.ComboBoxintitulé & "'")
   Me.ComboBoxrecette.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBoxrecette_click()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & Fich
  Sql = "SELECT * FROM [" & Me.ComboBoxchoix_onglets & "$A1:C1000] WHERE intitulé='" &   Me.ComboBoxintitulé & "' AND recette='" & _
  Me.ComboBoxrecette & "'"
  Set rs = cnn.Execute(Sql)
  Me.TextBox1 = rs("Libellé")
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Menu 4 niveaux avec choix du fichier et de la feuille (ADO)

ADORecette2

Dim Répertoire
Private Sub UserForm_Initialize()
  Répertoire = ThisWorkbook.Path & "\" ' adapter
  nf = Dir(repertoire & "listes_recettes*.xls") ' premier fichier xls
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir
  Loop
End Sub

Private Sub ChoixFichier_click()
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & Répertoire & Me.ChoixFichier
  Set cata.ActiveConnection = cnn
  For Each t In cata.Tables
    If Right(t.Name, 1) = "$" Then Me.ComboBoxchoix_onglets.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBoxchoix_onglets_click()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & Répertoire & Me.ChoixFichier
  Set rs = cnn.Execute("SELECT intitulé FROM [" & _
  Me.ComboBoxchoix_onglets & "$A1:C1000] WHERE intitulé<>'' GROUP BY intitulé")
  Me.ComboBoxintitulé.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Me.ComboBoxintitulé.ListIndex = -1
  Me.ComboBoxrecette.ListIndex = -1
End Sub

Eléments communs de 2 listes dans 2 classeurs fermés

ADOSource.Xls
Nom

Durand
Martin
Toto
Koko
Kiki

ADOSource2.Xls
Nom

Momo
Martin
Toto
Titi
Kiki
Zoe

Résultat

Kiki
Martin
Toto

champ:MaBD =Feuil1!$A$1:$A$500

champ:MaBD =Feuil1!$A$1:$A$500

 


Sub essai()
 '--- 1ere liste
 'Microsoft ActiveX DataObject doit être coché
  repertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
  repertoire & "\" & "ADOsource.xls"
  Set rs = cnn.Execute("SELECT nom FROM MaBD WHERE nom<>'' Order By nom")
  tbl = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  '--- 2eme liste
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
  repertoire & "\" & "ADOsource2.xls"
  Set rs = cnn.Execute("SELECT nom FROM MaBD WHERE nom<>'' Order By nom")
  tbl2 = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  '---- Communs
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In tbl
     If Not MonDico1.Exists(c) Then MonDico1.Add c, c
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In tbl2
    If MonDico1.Exists(c) Then
       If Not mondico2.Exists(c) Then mondico2.Add c, c
    End If
  Next c
  [A2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub

Lignes communes à 2 BD d'un autre classeur fermé

On veut les lignes communes à 2 BD d'un classeur fermé BDCommunsADO.xls.
Les BD sont nommées BDN1 et BDN2.

La requête SQL

SELECT * FROM BDN1,BDN2 WHERE bdn1.entreprise=bdn2.entreprise AND bdn1.cp=bdn2.cp AND   bdn1.code=bdn2.code AND bdn1.ville=bdn2.ville

Donne les lignes communes

Sub Communs()
  ' Microsoft ActiveX DataObject doit être coché
  ' les BD sont dans un autre classeur (BDCommunsADO.xls) sont nommées BDN1 et BDN2
  ' 1,5 sec pour 10.000 éléments

  repertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & repertoire & "\" & "BDCommunsADO.xls"
  Sql = "SELECT * FROM BDN1,BDN2 WHERE bdn1.entreprise=bdn2.entreprise AND bdn1.cp=bdn2.cp AND   bdn1.code=bdn2.code AND bdn1.ville=bdn2.ville "
  Set rs = cnn.Execute(Sql)
  tbl = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  [A2].Resize(UBound(tbl, 2) + 1, 4) = Application.Transpose(tbl)
End Sub

Formulaire avec BD Access

Une BD Access Access2000.mdb contient une table Client avec un champ Nom_client.

On initialise un combobox avec :

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

Donnée/Validation avec Access

DVAccess

Le menu en B2 est crée avec : Données/Validation/Liste =MaListeAccess.
La liste est créée dans l'onglet Liste lorsque l'opérateur selectionne la cellule B2. Le nom de champ MaListeAccess est:=DECALER(Liste!$A$2;;;NBVAL(Liste!$A:$A)-1)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    repertoire = ThisWorkbook.Path & "\"
    Set cnn = New ADODB.Connection
    cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & repertoire & "Access2000.mdb"
    Set rs = cnn.Execute("SELECT nom_client FROM client Order By nom_client")
    Sheets("Liste").[A2].CopyFromRecordset rs
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
   End If
End Sub

Données/Validation avec ADO

DV ADO

Autres méthodes pour lire une cellule ou un champ d'un classeur fermé

Créer une liaison avec un classeur fermé

Liaison Classeur fermé
Article4
Liaison Classeur fermé intuitif
Liaison Classeur fermé intuitif 2 colonnes
Liaison Classeur fermé intuitif 2 colonnes Enreg

Sub LiaisonFichier()
  Chemin = ThisWorkbook.Path ' Adapter
  Fichier = "Article4.xls" ' Adapter
  onglet = "Feuil1" ' Adapter
  ChampAlire = "A1:E100" ' Adapter
  ChampOuCopier = "A1:E100" ' Adapter
  LitChamp ChampOuCopier, Chemin, Fichier, onglet, ChampAlire
End Sub

Sub LitChamp(ChampOuCopier, Chemin, Fichier, onglet, ChampAlire)
  Range(ChampOuCopier).FormulaArray = "='" & Chemin & "\[" & Fichier & "]" & onglet & "'!" & ChampAlire
  'Range(ChampOuCopier) = Range(ChampOuCopier).Value ' Supprime liaison
End Sub

Lire dans un classeur fermé variable

Lecture d'une cellule

RecupClasseurFermé

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    Chemin = ThisWorkbook.Path
    Fichier = [B2]
    [B5].Formula = "='" & Chemin & "\[" & Fichier & "]Feuil1'!B15"
    [B5].Value = [B5].Value
  End If
End Sub

Lecture d'un champ d'un classeur fermé variable

Lecture fichier fermé
ca2009

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
     ChampOuCopier = "A5:B16"
     Chemin = ThisWorkbook.Path
     Fichier = [B2]
     onglet = "Feuil1"
     ChampAlire = "A2:B13"
     LitChamp ChampOuCopier, Chemin, Fichier, onglet, ChampAlire
  End If
End Sub

Sub LitChamp(ChampOuCopier, Chemin, Fichier, onglet, ChampAlire)
  Range(ChampOuCopier).FormulaArray = "='" & Chemin & "\[" & Fichier & "]" & onglet & "'!" & ChampAlire
  Range(ChampOuCopier) = Range(ChampOuCopier).Value
End Sub

Macro Excel4

Sub Excel4()
  repertoire = ThisWorkbook.Path & "\"
  classeur = "boulogne.xls"
  temp = Application.ExecuteExcel4Macro("'" & repertoire & "[" & classeur & "]feuil1'!R1C1")
End Sub

Sub Excel4()
  repertoire = ThisWorkbook.Path & "\"
  classeur = "BDSource.xls"
  i = 1
  Do
    temp = Application.ExecuteExcel4Macro("'" & repertoire & "[" & classeur & "]feuil1'!R" & i & "C1")
    If temp <> 0 Then
      Cells(i, 1) = temp
      Cells(i, 2) = Application.ExecuteExcel4Macro("'" & repertoire & "[" & classeur & "]feuil1'!R" & i & "C2")
      i = i + 1
    End If
  Loop Until temp = 0
End Sub

Récupération du contenu des colonnes B des Fichierxxx d'un répertoire.

[IV1].FormulaLocal = "=NBVAL('" & Chemin & "\[" & Fichier & "]Screptre'!$B:$B)"

donne le nombre de lignes de la colonne B.

Sub LitClasseurFermé()
  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path
  Fichier = Dir(Chemin & "\" & "fichierxxx*")
  Do While Fichier <> ""
    [IV1].FormulaLocal = "=NBVAL('" & Chemin & "\[" & Fichier & "]Screptre'!$B:$B)"
    [IU1].End(xlToLeft).Select
    If ActiveCell <> "" Then ActiveCell.Offset(0, 1).Select
      ChampOuCopier = ActiveCell.Resize([IV1], 1).Address
      onglet = "Screptre"
      ChampAlire = "B1:B" & [IV1]
      LitChamp ChampOuCopier, Chemin, Fichier, onglet, ChampAlire
      Fichier = Dir
   Loop
End Sub

Sub LitChamp(ChampOuCopier, Chemin, Fichier, onglet, ChampAlire)
  Range(ChampOuCopier).FormulaArray = "='" & Chemin & "\[" & Fichier & "]" & onglet & "'!" & ChampAlire
  Range(ChampOuCopier) = Range(ChampOuCopier).Value
End Sub

Noms de champ d'une BD

Pour récupérer les noms de champ d'une BD nommée BD dans un claseur CP_PAYS.xls

Sub NomsChampBD()
  Dim rs As ADODB.Recordset
  repertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & repertoire & "\" & "CP_PAYS.xls"
  Set rs = cnn.Execute("[BD]")
  For i = 0 To rs.Fields.Count - 1
    [A1].Offset(0, i) = rs.Fields(i).Name
  Next i
End Sub

Listes en cascade avec ADO

Un fichier CP_Pays.Xls contient une BD nommée BD. Les codes postaux sont au format texte.

ListeCascadeADO

Private Sub UserForm_Initialize()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & "CP_PAYS.xls"
  Set rs = cnn.Execute("SELECT code FROM BD WHERE code<>'' GROUP BY code")
  Me.ComboBoxCP.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBoxCP_Change()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & "CP_PAYS.xls"
  Set rs = cnn.Execute("SELECT Lieu FROM BD WHERE code='" & Me.ComboBoxCP & "'")
  Me.ComboBoxLieu.List = Application.Transpose(rs.GetRows)
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBoxLieu_Change()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & "CP_PAYS.xls"
  Sql = "SELECT canton,pays FROM BD WHERE code='" & Me.ComboBoxCP & "' AND lieu='" & _
    Me.ComboBoxLieu & "'"
  Set rs = cnn.Execute(Sql)
  Me.TextBoxCanton = rs("canton")
  Me.TextBoxPays = rs("Pays")
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Modification d'une cellule dans un classeur fermé

Sub ModifCelluleClasseurFermé()
  repertoire = ThisWorkbook.Path & "\"
  Set Cnn = New ADODB.Connection
  Fichier = "yyy.xls"
  Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & repertoire & Fichier & ";" & _
    "Extended Properties=""Excel 8.0;HDR=No;"";"
  Set Rs = New ADODB.Recordset
  Rs.Open "SELECT * from [Feuil1$b3:b3]", Cnn, adOpenKeyset, adLockOptimistic
  Rs(0).Value = "xxxxxx"
  Rs.Update
  Rs.Close
  Cnn.Close
End Sub

Ajout avec ADO

On veut ajouter des informations de AdoOrigine.xls dans AdoDestination.xls

ADOAjout

AdoOrigine.xls

ADODestination.XLS

Sub ajout()
  ' cocher Microsoft Activex Data Object 2.8
  ChDir ActiveWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=ADODestination.XLS;
    Extended Properties=Excel 8.0;"
  For i = 1 To [BDorigine].Rows.Count - 1
    Sql = "INSERT INTO BDDestination (Nom,Prenom,age,DateNaissance,Ville)" _
      & " Values('" & [BDorigine].Cells(i + 1, 1) & "'," & _
        "'" & [BDorigine].Cells(i + 1, 2) & "'," & _
        [BDorigine].Cells(i + 1, 3) & "," & _
          "#" & Format([BDorigine].Cells(i + 1, 4), "mm/dd/yy") & "#," & _
           "'" & [BDorigine].Cells(i + 1, 5) & "')"
      'MsgBox Sql
      cnn.Execute Sql
   Next i
   cnn.Close
   Set cnn = Nothing
End Sub

Autre écriture

Sub ajout2()
' cocher Microsoft Activex Data Object 2.8
Dim rs As New ADODB.Recordset
ChDir ActiveWorkbook.Path
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=ADODestination.XLS;Extended Properties=Excel 8.0;"
rs.Open "BDDestination", cnn, adOpenDynamic, adLockOptimistic
For i = 1 To [BDorigine].Rows.Count - 1
  rs.AddNew
  rs!Nom = [BDorigine].Cells(i + 1, 1)
  rs!prenom = [BDorigine].Cells(i + 1, 2)
  rs!age = [BDorigine].Cells(i + 1, 3)
  rs!DateNaissance = [BDorigine].Cells(i + 1, 4)
  rs!ville = [BDorigine].Cells(i + 1, 5)
  rs.Update
Next i
rs.Close
cnn.Close
End Sub

Liste sans doublons triée avec ADO

La liste est stockée dans un autre fichier ADOExcel.2XLS.
La requête SQL fournit la liste sans doublons et triée.

    

Private Sub UserForm_Initialize()
  ' dans Outils/Références cocher
  ' Microsoft ActivexDataObject 2.8 Library
  ChDir ActiveWorkbook.Path
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=ADOExcel.2XLS"
  Set rs = cnn.Execute("SELECT service FROM MaListe GROUP BY Service")
  Do While Not rs.EOF
    Me.Choix.AddItem rs("Service")
    rs.MoveNext
  Loop
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Private Sub B_ajout_Click()
  Set Cnn = New ADODB.Connection
  Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=ADOExcel2.XLS;Extended Properties=Excel 8.0;"
  Sql = "INSERT INTO Maliste (service) VALUES('qqq')"
  Cnn.Execute Sql
  Cnn.Close
  Set Cnn = Nothing
End Sub

Totalisation par mois,no_cli,commercial

On veut obtenir le total des montants par mois et par no de client. Le champ A1:E8 est nommé MaBD.

Sub groupe()
   'Outils/Références Microsoft ActiveX Data Object 2.8
  ActiveWorkbook.Names.Add Name:="MaBd", RefersTo:=Sheets(1).[A1].CurrentRegion
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" &      ThisWorkbook.Name
     Sql = "SELECT mois,no_cli,commercial,sum(montant) as ttal From MaBD Group BY         mois,no_cli,commercial"
     Set rs = cnn.Execute(Sql)
     i = 2
     Do While Not rs.EOF
       Sheets(2).Cells(i, 1) = rs("mois")
       Sheets(2).Cells(i, 2) = rs("No_cli")
       Sheets(2).Cells(i, 3) = rs("Commercial")
       Sheets(2).Cells(i, 4) = rs("ttal")
       rs.MoveNext
       i = i + 1
    Loop
    rs.Close
    cnn.Close
    Set rs = Nothing
End Sub

Comptage 2 critères

Compte les occurences sur 2 critères

Sub compteOccurences2critères2()
 'Outils/Références Microsoft ActiveX Data Object 2.8
  ActiveWorkbook.Names.Add Name:="MaBd", RefersTo:=Sheets(1).[A1].CurrentRegion
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name
  Sql = "SELECT data1,data2,count(*) as Nbre from MaBD GROUP BY data1,data2"
  Set rs = cnn.Execute(Sql)
  [k2].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
End Sub

Autre exemple

On veut compter le nombre de lignes par mois et par référence.

Sub Essai()
    Dim rs As ADODB.Recordset
   Set cnn = New ADODB.Connection
   cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & _
      ThisWorkbook.Path & "\" & ThisWorkbook.Name
   Sql = "SELECT month(dates) as mois,ref,count(ref) as Nbr From BD Group BY month(dates),ref"
   Set rs = cnn.Execute(Sql)
   ligne = 2
   Do While Not rs.EOF
     Cells(ligne, "E") = DateSerial(2006, rs("mois"), 1)
     Cells(ligne, "F") = rs("ref")
     Cells(ligne, "G") = rs("nbr")
     ligne = ligne + 1
     rs.MoveNext
   Loop
End Sub

Nombre de commandes distinctes par vendeur

Sub groupe()
  'Outils/Références Microsoft ActiveX Data Object 2.8
  ActiveWorkbook.Names.Add Name:="MaBd", RefersTo:=Sheets(1).[A1].CurrentRegion
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name
  Sql = "select vendeur,count(*) as ttal from (SELECT distinct vendeur,cmd From MaBD) group by vendeur"
  Set rs = cnn.Execute(Sql)
  [d2].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
End Sub

ADOGroupBY

Lecture Access ADO

Sub LectureAccess()
'Microsoft ActivexDataObject 2.8 Library
ChDir ActiveWorkbook.Path
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=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

ou

Sub LectureAccess2()
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 * 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

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 Access

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

Liste des d'items sans doublons et nombre d'items


Sub essai2()
  ' Microsoft ActiveX DataObject doit être coché dans Outils/Référence
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & ThisWorkbook.FullName
  Set rs = cnn.Execute("SELECT titre,count(*) as nb FROM maBD group by titre")
  [c2].CopyFromRecordset rs
End Sub

ou

' Do While Not rs.EOF
' temp = temp & rs("titre") & ":" & rs("nb") & " "
' rs.MoveNext
' Loop
' MsgBox temp

Liste des personnes par ville sans doublons

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 2 Then
    [E1:I100].ClearContents
    Set MonDico = CreateObject("Scripting.Dictionary")
    Set MonDico2 = CreateObject("Scripting.Dictionary")
    For Each c In Range("b2", [b65000].End(xlUp))
      temp = c.Value & c.Offset(0, -1).Value
      If Not MonDico2.Exists(temp) Then
         temp = c.Value & c.Offset(0, -1).Value
         MonDico2.Add temp, temp
         If Not MonDico.Exists(c.Value) Then
            MonDico(c.Value) = c.Offset(0, -1) & " "
         Else
            MonDico(c.Value) = MonDico(c.Value) & c.Offset(0, -1) & " "
         End If
     End If
   Next c
   a = MonDico.keys
   b = MonDico.items
   For i = LBound(b) To UBound(b)
     Cells(1, i + 5) = a(i)
     c = Split(b(i), " ")
     Cells(2, i + 5).Resize(UBound(c), 1) = Application.Transpose(c)
   Next i
  End If
End Sub

Recherche intuitive dans liste externe

La liste est alimentée par une BD externe(BDPROD.XLS)

BDProd.Xls
ListeDeroul.Xls

Dim Liste()
Private Sub UserForm_Initialize()
  'Microsoft ActiveX DataObject doit être coché
  ' Champ nommé BD
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
     ThisWorkbook.Path & "\" & "BDPROD.xls"
  Set rs = cnn.Execute("SELECT count(*) as nb FROM [TABLE$A1:D1000] where libellé<>''")
  ReDim Liste(0 To rs("nb"), 1 To 4)
  'Set rs = cnn.Execute("SELECT libellé,Codification,Prix,Unité FROM BD where libellé<>''")
  Set rs = cnn.Execute("SELECT libellé,Codification,Prix,Unité FROM [TABLE$A1:D1000] where libellé<>''")
  Me.ListBox1.Clear
  i = 0
  Do While Not rs.EOF
     On Error Resume Next ' cellules vides
     Liste(i, 1) = rs("libellé")
     Liste(i, 2) = rs("codification")
     Liste(i, 3) = rs("Prix")
     Liste(i, 4) = rs("Unité")
     On Error GoTo 0
     i = i + 1
    rs.MoveNext
  Loop
  Me.ListBox1.List = Liste
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  Liste = Me.ListBox1.List
End Sub

Private Sub TextBox1_Change()
  Me.ListBox1.Clear
  j = 0
  For i = LBound(Liste) To UBound(Liste)
     If UCase(Liste(i, 0)) Like "*" & UCase(Me.TextBox1) & "*" _
       Or "*" & UCase(Liste(i, 1)) Like "*" & UCase(Me.TextBox1) & "*" Then
        Me.ListBox1.AddItem Liste(i, 0)
        Me.ListBox1.List(j, 1) = Liste(i, 1)
        Me.ListBox1.List(j, 2) = Liste(i, 2)
        Me.ListBox1.List(j, 3) = Liste(i, 3)
        j = j + 1
     End If
   Next i
End Sub

Private Sub ListBox1_Click()
   ActiveCell = Me.ListBox1
   ActiveCell.Offset(, 1) = Me.ListBox1.Column(1)
   ActiveCell.Offset(, 2) = CDbl(Me.ListBox1.Column(2))
   ActiveCell.Offset(, 3) = Me.ListBox1.Column(3)
   Unload Me
End Sub

Liste des feuilles d'un classeur fermé

ListeFeuillesClasseurFermé

Sub ListeFeuilles()
  'Microsoft ActiveX DataObject doit être coché
  répertoire = ThisWorkbook.Path & "\" ' adapter
  Fich = "x.xls"
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & répertoire & Fich & ";Extended      Properties=Excel 8.0;"
  Set cata.ActiveConnection = cnn
  i = 2
  For Each t In cata.Tables
    Sheets(1).Cells(i, 1) = Replace(Replace(t.Name, "$", ""), "'", "")
    i = i + 1
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

ComboBox avec la liste des feuilles d'un classeur fermé

ADOComboBox

Dim fich
Private Sub UserForm_Initialize()
  'Microsoft ActiveX DataObject doit être coché
  fich = "classeur1.xls"
  répertoire = ThisWorkbook.Path & "\" ' adapter
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & fich
  Set cata.ActiveConnection = cnn
  For Each t In cata.Tables
     If Right(t.Name, 1) = "$" Then Me.ListBox1.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Choix du classeur dans un répertoire

ADOClasseurFermé

Dim repertoire
Private Sub UserForm_Initialize()
  repertoire = ThisWorkbook.Path & "\" ' adapter
  nf = Dir(repertoire & "*.xls") 'premier fichier xls
  Do While nf <> ""
    Me.ComboBox1.AddItem nf
    nf = Dir
  Loop
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
' Microsoft ActiveX DataObject doit être coché
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  FichXLS = Me.ComboBox1
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & repertoire & FichXLS & ";Extended       Properties=Excel 8.0;"
  Set cata.ActiveConnection = cnn
  Me.ListBox1.Clear
  For Each t In cata.Tables
     If Right(t.Name, 1) = "$" Then Me.ListBox1.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Nombre de feuilles d'un classeur fermé

Sub NombreFeuillesClasseurFermé()
' Microsoft ActiveX DataObject doit être coché
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  FichXLS = "adosource.xls"
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & repertoire & FichXLS & ";Extended     Properties=Excel 8.0;"
  Set cata.ActiveConnection = cnn
  MsgBox cata.tables.Count
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Le langage SQL

Ci dessous, nous avons regroupé quelques commandes du langage SQL.

Requêtes de sélection

SELECT champ1,champ2,.. FROM table1,table2,…
WHERE condition GROUP BY champ1,champ2,.. ORDER BY champ1,champ2,.. ASC/DESC

Exemples:
SELECT Société,ville FROM Clients WHERE ville=’Paris’ ORDER BY société
sélectionne dans la table Clients les clients de paris
.
SELECT Société,ville FROM Clients WHERE ville LIKE ’Par*’ ORDER BY société
sélectionne dans la table Clients les clients pour lesquels la ville commence par Par

SELECT Société,ville FROM Clients WHERE société LIKE ’[A-D]*’ ORDER BY société
Donne la Société et la ville pour les sociétés dont le nom commence par A,B,C,D

SELECT * FROM Ventes WHERE DateVente>=#2/24/2002# ORDER BY DateVente DESC
Donne les enregistrements de la table Ventes pour les dates de vente supérieures au 24/2/2002

SELECT DISTINCT ville FROM clients
Donne le liste des villes de la table Clients. Cette liste est en ordre croissant.

SELECT ville,Sum(Ca) AS TotCa FROM clients GROUP BY ville
Donne le liste des villes de la table Clients. Cette liste est en ordre croissant.

Requêtes de sélection emboîtées
SELECT * FROM clients WHERE CodeClient IN (SELECT codeClient FROM ClientsChoisis)
Donne les enregistrements de la table Clients pour lesquels les codes sont égaux à ceux de la table ClientsChoisis.

Requête union
SELECT CodeClient,Société FROM Clients UNION SELECT CodeClient,Société FROM Clients2
Donne l’ensemble des clients de la table Clients et de la table Clients2. Les clients communs n’apparaissent qu’une fois.

Ajout d’une constante et d’une table
SELECT "(tous)" FROM Clients UNION SELECT Ville FROM Clients GROUP BY ville
Ajoute le libellé (tous) à la liste des villes de la table Clients

Requêtes Actions

Insertion des enregistrements d'une table dans une autre table
Sélectionne des enregistrements dans une table et les insère dans une autre

INSERT INTO ClientsChoisis (codeClient,Société) SELECT CodeClient,Société FROM Clients WHERE Ville=’Paris’
Ajoute à la table ClientsChoisis les clients de Paris de la table Clients. La table ClientsChoisis doit exister

Insère un enregistrement dans la table
INSERT INTO ClientsChoisis (CodeClient, Société) Values(7, "ZIG ZAG")
Ajoute un client dans la table ClientsChoisis

Suppression d’enregistrements
DELETE FROM Clients WHERE CodeClient=7
Supprime de la table Clients le client dont le code est 7

Mise à jour d’enregistrements
UPDATE Clients SET Société="ZIG ZAG", Ville="Paris" WHERE CodeClient=6
Modifie la ville pour le client dont le code est égal à 6

UPDATE clients SET ville=Ucase(Ville)
Convertit en majuscule les villes de la table Clients.

Création de table
INSERT INTO temp SELECT Société,Ville FROM clients WHERE ville=’Paris’

Sélectionne dans la table Clients les enregistrements des clients de Paris et les met dans la table Temp
.Si la table Temp exitse, elle est d’abord supprimée.

Suppression de table
DROP TABLE temp

Fonction Guillemet()

Cette fonction est utilisée dans les requêtes SQL pour doubler les apostrophes dans les chaînes qui contiennent des apostrophes.

Select * FROM clients Where société=Guillemet(“Mac'Harn Group”)

? Guillemet("Mac'Harn Group")
Mac''Harn Group

Function Guillemet(mot) ' Remplace ' par '' pour SQL
  Dim temp
  temp = MonReplace(mot, "'", "''")
  Guillemet = temp
End Function


 


Exemples

ADO
ADOAjout
ADOGroupe