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.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("[Feuil1$A1:C100]")
  [A2].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é
'
' Nom Prenom Salaire
' Dupont Jean 4000
' Martin Daniel 5000
' Campas Pierre 6000

  Set cnn = New ADODB.Connection
  fichier = "AdoSource.xls"
  répertoire = ThisWorkbook.Path
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("[Feuil1$A1:C100]")
  Tbl = rs.GetRows
  For i = LBound(Tbl) To UBound(Tbl)
    For k = 0 To UBound(Tbl, 2)
       Cells(k + 2, i + 1) = Tbl(i, k)
    Next k
  Next i
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

On récupère:

Autre syntaxe

Sub GetRows2()
  'Microsoft ActiveX DataObject doit être coché
  répertoire = ThisWorkbook.Path
  fichier = "AdoSource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("SELECT nom,Prenom,salaire FROM MaBD WHERE nom<>'' Order By nom")
  Tbl = Application.Transpose(rs.GetRows)
  [A15].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Sub

Syntaxes de Open

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

  ou

  cnn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & répertoire & "\" & fichier & ";HDR=Yes';"

  ou

  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "\" & fichier

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

  Set cnn = New ADODB.Connection
  répertoire = ThisWorkbook.Path
  fichier = "AdoSource.xls"
   cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
       répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
   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
répertoire = ThisWorkbook.Path
fichier = "AdoSource.xls"
chemin = répertoire & "\" & fichier
'cnn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & chemin & ";HDR=Yes';"
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
Set rs = cnn.Execute("SELECT count(*) as nb FROM maBD")
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)

Function LitUneCellule(répertoire 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.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.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

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

Avec la macro Excel4

Lit cellule Excel4

Sub Essai2()
  résult = LitCellule("C:\mesdoc\excelmacronouveau\1001exemples", "adosource.xls", "feuil1", "R3C1")
  MsgBox résult
End Sub

Function LitCellule(répertoire, fichier, feuille, cellule)
  chaine = "'" & répertoire & "\[" & fichier & "]" & feuille & "'!" & cellule
  LitCellule = Application.ExecuteExcel4Macro(chaine)
End Function

Lecture d'un champ dans un classeur fermé (sans ADO)

Sub LitChampClasseurFermé()
  LitChamp "J1:K4", ThisWorkbook.Path, "adosource.xls", "feuil1", "A1:B4"
End Sub

Sub LitChamp(ChampOuCopier, Répertoire, Fichier, Feuille, ChampAlire)
  Range(ChampOuCopier).FormulaArray = "='" & Répertoire & "\[" & Fichier & "]" & Feuille & "'!" & ChampAlire
  Range(ChampOuCopier) = Range(ChampOuCopier).Value
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

ADO Ecrit

Sub Ecrit()
  ModifieUneCellule "c:\mesdoc\excelmacronouveau\1001exemples", "adosource.xls", "feuil1", "A2", "Durand"
End Sub

Sub ModifieUneCellule(répertoire As String, fichier, feuille As String, cellule As String, NouvelleValeur)
  'Microsoft ActiveX DataObject 2.8 doit être coché
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.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é
  répertoire = ThisWorkbook.Path
  fichier = "ADOsource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=yes'"
  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$100 a été défini.

Sub ImporteBD2()
  'Microsoft ActiveX DataObject doit être coché
  répertoire = ThisWorkbook.Path
  fichier = "ADOsource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=yes'"
  Set rs = cnn.Execute("SELECT nom,prenom,salaire FROM [MaBD] Where nom<>''")
  [A2].CopyFromRecordset rs
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
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
  fichier = "Article.xls"
  moncode = "Art2"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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
  fichier = "Article.xls"
  cnn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & répertoire & "\" & fichier & ";HDR=Yes';"
  ' cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("SELECT * FROM BD WHERE code='" & moncode & "'")
  Me.ListBox1.Clear
  If rs.EOF() Then
     Me.TextBox2 = "Inconnu"
     Me.TextBox2.BackColor = vbRed 'RGB(255, 0, 0)
  Else
    Me.TextBox2 = ""
    Me.TextBox2.BackColor = vbWhite
    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
  fichier = "Article3.xls"
  cnn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & répertoire & "\" & fichier & ";HDR=Yes';"
  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
  fichier = "Article3.xls"
  cnn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & répertoire & "\" & fichier & ";HDR=Yes';"
  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()
  répertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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
  Me.L_modif.Caption = "Création"
  Me.b_modif.Locked = True
End Sub

Private Sub B_validation_Click()
  répertoire = ThisWorkbook.Path & "\"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * FROM BD", cnn, adOpenDynamic, adLockOptimistic
  If Me.TextBox7 <> "" And Me.TextBox3 <> "" And Me.TextBox6 <> "" And Me.TextBox5 <> "" And       Me.TextBox4 <> "" Then
     If Not IsDate(Me.TextBox6) Then
         MsgBox "Saisissez une date!"
        Me.TextBox6 = ""
        Me.TextBox6.SetFocus
        Exit Sub
     End If
     rs.AddNew
     rs(0).Value = Me.TextBox7
     rs(4).Value = Me.TextBox3
     rs(3).Value = Me.TextBox6
     rs(2).Value = Me.TextBox5
     rs(1).Value = Me.TextBox4
     rs.Update
      B_raz_Click
   Else
      MsgBox "Complétez les champs"
      Me.TextBox5.SetFocus
      Exit Sub
  End If
  rs.Close
  cnn.Close
  Me.B_validation.Locked = True
  Me.b_modif.Locked = False
End Sub

Modification enregistrement

ADO Modif

Un fichier ADOsource.Xls contient

Sub ModifEnregistrement()
Set cnn = New ADODB.Connection
répertoire = ThisWorkbook.Path
fichier = "ADOsource.xls"
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
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()
  répertoire = ThisWorkbook.Path & "\"
  fichier = "ADOsource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
   répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * from MaBD", 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
  répertoire = ThisWorkbook.Path
  fichier = repertoire & "ADOsource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Sql = "INSERT INTO MaBD (Nom,Prenom,salaire) Values('titi','jean',4000)"
  cnn.Execute Sql
  cnn.Close
End Sub

Recherche d'un Item

Sub RechercheItem()
  ' Microsoft ActiveX DataObject doit être coché
  ' Champ nommé MaBD avec lignes vides
  Set cnn = New ADODB.Connection
  nomcherche = "Martin"
  répertoire = ThisWorkbook.Path & "\"
  fichier = "AdoSource.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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

Modification cellule

Sub ModifCelluleClasseurFermé()
  répertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  fichier = "yyyy.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.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

Récupération des enregistrements dans un tableau

Sub RecupTableau()
   ' Microsoft ActiveX DataObject doit être coché
   '
   ' Nom Prenom Salaire
   ' Dupont Jean 4000
   ' Martin Daniel 5000
   ' Campas Pierre 6000
   '
   Set cnn = New ADODB.Connection
   cnn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
      ThisWorkbook.Path & "\adosource.xls;Extended Properties=""Excel 12.0;HDR=yes;"""
   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()
  répertoire = ThisWorkbook.Path
  fichier = "AdoSource.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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é
  Set cnn = New ADODB.Connection
  cnn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     ThisWorkbook.Path & "\adosource.xls;Extended Properties=""Excel 12.0;HDR=yes;"""
  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
  répertoire = ThisWorkbook.Path
  fichier = "fichier2.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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
  fichier = "Article.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("SELECT continent FROM BD WHERE continent<>''Group By 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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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, 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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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_click()
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
      Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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

Dim f
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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 Répertoire, Fichier
Private Sub UserForm_Initialize()
  Fichier = "LISTES_RECETTES.xls"
  Répertoire = ThisWorkbook.Path & "\" ' adapter
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set cata.ActiveConnection = cnn
  For Each t In cata.Tables
    If Right(t.Name, 1) = "$" Then
        Me.ComboBoxchoix_onglets.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
    End If
   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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
      Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Répertoire & "\" & Me.ChoixFichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Répertoire & "\" & Me.ChoixFichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Répertoire & "\" & Me.ChoixFichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Répertoire & "\" & Me.ChoixFichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
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

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

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

Dim répertoire, fichier
Private Sub UserForm_Initialize()
  Dim rs As ADODB.Recordset
  répertoire = ThisWorkbook.Path
  fichier = "CP_PAYS.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
      répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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 "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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é()
  répertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  fichier = "yyyy.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
      répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=No'"
  Set rs = New ADODB.Recordset
  rs.Open "SELECT * from [Feuil1$b3:b3]", cnn, adOpenKeyset, adLockOptimistic
  'MsgBox rs(0)
  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
  répertoire = ThisWorkbook.Path
  fichier = "AdoDestination.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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) & "')"
      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
  répertoire = ThisWorkbook.Path
  fichier = "AdoDestination.xls"
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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

ADO Excel programme
ADO Excel Données

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

Dim Répertoire, Fichier
Private Sub UserForm_Initialize()
  ' dans Outils/Références cocher Microsoft ActivexDataObject 2.8 Library
  Répertoire = ThisWorkbook.Path
  Fichier = "ADOExcel2.xls"
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set rs = cnn.Execute("SELECT service FROM MaListe GROUP BY Service")
  Do While Not rs.EOF
    Me.ComboBox1.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.ACE.OLEDB.12.0;Data Source=" & _
     Répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Sql = "INSERT INTO Maliste (service) VALUES('Servicexx')"
  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.

ADO SQL Groupe

Sub groupe()
  ActiveWorkbook.Names.Add Name:="MaBd", RefersTo:=[A1].CurrentRegion
  Dim rs As ADODB.Recordset
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & 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
     Cells(i, 8) = rs("mois")
     Cells(i, 9) = rs("No_cli")
     Cells(i, 11) = 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

ADO Comptage 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)
  [E2].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.

ADO Regroupe 2 critères

Sub regroupeMois()
  'Outils/Références Microsoft ActiveX Data Object 2.8
  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"
  Dim rs As ADODB.Recordset
  Set rs = cnn.Execute(Sql)
  ligne = 2
  Do While Not rs.EOF
     Cells(ligne, "E") = DateSerial(2017, 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
  répertoire = ThisWorkbook.Path
  fichier = ThisWorkbook.Name
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & répertoire & "\" & fichier
  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
  répertoire = ThisWorkbook.Path
  fichier = "BDPROD.xls"
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  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
      On Error Resume Next
      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)
      On Error GoTo 0
      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
  fichier = "adosource.xls"
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
  répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set cata.ActiveConnection = cnn
  i = 2
  For Each t In cata.Tables
    If Right(t.Name, 1) = "$" Then
        Sheets(1).Cells(i, 1) = Replace(Replace(t.Name, "$", ""), "'", "")
        i = i + 1
     End If
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

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

ADOComboBox

Dim fichier
Private Sub UserForm_Initialize()
  'Microsoft ActiveX DataObject doit être coché
  fichier = "classeur1.xls"
  répertoire = ThisWorkbook.Path ' adapter
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
     répertoire & "\" & fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
  Set cata.ActiveConnection = cnn
  For Each t In cata.Tables
     Me.ComboBox1.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Private Sub ComboBox1_Click()
  temp = Me.ComboBox1
  Workbooks.Open fichier
  Sheets(temp).Select
End Sub

Choix du classeur dans un répertoire

ADOClasseurFermé

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

Private Sub ComboBox1_click()
   ' Microsoft ActiveX DataObject doit être coché
   Set cnn = CreateObject("ADODB.Connection")
   Set cata = CreateObject("ADOX.Catalog")
   If Me.ComboBox1 <> ".xls" Then
     Fichier = Me.ComboBox1
     cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        répertoire & "\" & Fichier & ";Extended Properties='Excel 12.0;HDR=Yes'"
     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 If
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