VBA - Relations entre tableaux Excel

Version imprimable

Voir 40 message(s) de cette discussion en une page

4 pièce(s) jointe(s)

VBA - Relations entre tableaux Excel

Bonjour,
J'ai 3 tableaux structurés et nommés - Clients, Animaux, Vétérinaires qui contiennent des identifiants uniques "ID" attribués aux différents clients, animaux et vétérinaires.

Tableau "Clients"
Pièce jointe 406575

Tableau "Vétérinaires"
Pièce jointe 406577

et pour le tableau "Animaux", il y a deux colonnes "IDVet" et "IDCli" qui correspondent au client et vétérinaire lié
Pièce jointe 406581

Quand je veux modifier un animal, j'importe dans un Userform les données de mon tableau ainsi que les "IDVet" et "IDCli".
Une fois mon animal sélectionné, voilà à quoi ressemble mon Userform:
Pièce jointe 406583

Les 2 ComboBox sont vides sont alimentées par leur tableau respectif:
Code:

1 2 3 CboMaitre.List = Range("Clients[Nom]:Clients[Prénom]").Value CboVet.List = Range("Veterinaires[Nom]:Veterinaires[Prénom]").Value
Donc la question est, Comment créer des relations entres Tableaux?
Comment est ce que je peux définir le listindex des 2 ComboBox?

Je souhaiterai avoir comme en SQL(Si ça peut aider à comprendre ce que je souhaite) un truc du genre:
Code:

1 2 3 4 5 6 7 Select Vet.Nom, Cli.Nom From Animaux Ani Left Outer Join Vétérinaires Vet on Ani.IDVet = Vet.ID 'Création du lien sur ID Left Outer Join Clients Cli on Ani.IDCli = Cli.ID 'Création du lien sur ID
Vous allez me dire, "Tu aurais du le faire en SQL" mais je ne sais pas comment alimenter une base SQL depuis un Userform et j'ai rien trouvé sur le sujet.

La finalité étant, vous l'aurez compris, de trouver le listindex des 2 Combobox

Merci

1 pièce(s) jointe(s)

Bonjour,

C'est sur un SGBD qu'il faut faire ça (genre Access e.g.).

Exemple de requête SQL sur des fichiers Excel pour prendre les communs entre 2 BD

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

Pgm joint sans SQL

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Compare Text
 Private Sub UserForm_Initialize()
  Me.Id = Application.Max([animaux[id]]) + 1
  Me.IdCli.List = [client].Value
  Me.IdVeto.List = [veto].Value
  Me.FamilleF.List = [Famille].Value
  Me.SexeF.List = [Sexe].Value
End Sub
 
Private Sub FamilleF_Change()
  Race = [Race].Value
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(Race)
    If Race(i, 1) = Me.FamilleF Then d(Race(i, 2)) = ""
  Next i
  Me.RaceF.List = d.keys
End Sub
 
Private Sub B_valid_Click()
  enreg = [animaux].Rows.Count + 1
  [animaux].Item(enreg, 1) = Val(Me.Id)
  [animaux].Item(enreg, 2) = Me.Nom
  [animaux].Item(enreg, 3) = Me.FamilleF
  [animaux].Item(enreg, 4) = Me.RaceF
  [animaux].Item(enreg, 5) = Me.SexeF
  [animaux].Item(enreg, 6) = Val(Me.IdCli)
  [animaux].Item(enreg, 7) = Val(Me.IdVeto)
End Sub

Boisgontier

26/08/2018, 17h31
78chris

Bonjour à tous

Tu as 2016 donc PowerQuery intégré : tu peux faire une requête qui synthétise les 3 tables et l'utiliser pour faciliter l'affichage dans le Userform mais bien sur, tu mets à jour les tableaux sources à la validation du Userform...

La requête est à créer une fois pour toutes (comme une vue de SGBD) mais à actualiser après MAJ des sources.
26/08/2018, 19h43
Floyd-44

Bonjour
J'ai bien pensé à Power Query pour ça mais je n'étais pas sûr que ma sœur (destinataire du fichier final) est xl 2016. Et vu que c'est une surprise, je me vois pas lui demander.
J'arrive à mes fins sinon avec un .find mais un homme avisé m'a fait comprendre que c'était loin d'être idéal...
Donc les jointures me paraissaient être la bonne solution
26/08/2018, 19h57
Invité

Bonsoir,
https://www.developpez.net/forums/d1.../#post10372486
26/08/2018, 20h56
boisgontierjacques

1 pièce(s) jointe(s)

>J'arrive à mes fins sinon avec un .find

Avec les tableaux dynamiques, il est + simple d'utiliser un VlookUp si on déplace les tableaux.

Me.NomClient = Application.VLookup(Val(Me.IdCli), [client], 2, False)
Me.NomVeto = Application.VLookup(Val(Me.IdVeto), [veto], 2, False)

Boisgontier
26/08/2018, 21h12
78chris

Re

Citation:

Envoyé par Floyd-44

...
J'ai bien pensé à Power Query pour ça mais je n'étais pas sûr que ma sœur (destinataire du fichier final) est xl 2016...

A noter pour info que cela marche aussi sur 2010 et 2013 si on installe l'add on gratuit
26/08/2018, 23h22
Floyd-44

Citation:

Envoyé par boisgontierjacques

[I]

Avec les tableaux dynamiques, il est + simple d'utiliser un VlookUp si on déplace les tableaux.

Me.NomClient = Application.VLookup(Val(Me.IdCli), [client], 2, False)
Me.NomVeto = Application.VLookup(Val(Me.IdVeto), [veto], 2, False)

C'est vrai, je pars là dessus. Je pense que je me prenais peut être un peu la tête avec ces histoires de jointures

Merci à tous pour votre aide
27/08/2018, 06h44
Floyd-44

Citation:

Envoyé par dysorthographie

Bonsoir,
https://www.developpez.net/forums/d1.../#post10372486

Bonjour
Merci pour le lien... j'ai passé pas mal de temps dessus mais il faut être raisonnable, je suis pas au niveau du tout pour assimiler le sujet.

Bonjour,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub teste()
 
Dim Rst As Object,Sql as string
Sql="Select Vet.Nom,Cli.Nom From [Animaux$] Ani "
Sql=Sql & " Left Outer Join [Vétérinaires$] Vet on Ani.IDVet = Vet.ID"
Sql=Sql & " Left Outer Join [Clients$] Cli on Ani.IDCli = Cli.ID"
With CreateObject("AdoDb.Connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Thisworkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
     Set Rst = .Execute(Sql) 
    For I = 0 To Rst.Fields.Count - 1  '--- Boucle sur les entêtes pour récupérer les noms ---
        Cells(1,1).Offset(0,i) = Rst.Fields(I).Name
    Next I    
    Range("A2").CopyFromRecordset Rst  'Ecrit le résultat de la requête dans la cellule A2
    .Close
 End With
End Sub

2 pièce(s) jointe(s)

Dysorthographie ,Merci pour ça.
J'ai fait le test et il me mettait comme message d'erreur "sub ou fonction non définie"
J'ai donc rajouté:
Code:

1 2 3 4 5 6 Dim Cn As ADODB.Connection Set Cn = New ADODB.Connection With Cn .Open 'etc.....
Ce message d'erreur est remplacé par un autre
Pièce jointe 406902
J'ai vérifié les orthographes 100 fois. C'est bien "Animaux" pour le tableau nommé et "Animal" pour la feuille qui le contient.

J'ai donc pris le nom de la feuille:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Dim Cn As ADODB.Connection Dim Rst As Object, Sql As String Sql = "Select Vet.Nom From [Animal$] Ani " Sql = Sql & " Left Outer Join [Veterinaire$] Vet on Ani.IDVet = Vet.ID" Sql = Sql & " Where Ani.ID = 5" Set Cn = New ADODB.Connection With Cn .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;""" Set Rst = .Execute(Sql) Range("A15").CopyFromRecordset Rst 'Ecrit le résultat de la requête dans la cellule A15 .Close End With
J'ai bien en A15 de la feuille "Animal" le nom du Vétérinaire
La boucle sur les entêtes me changeait les noms des entêtes de colonnes de la feuille "Animal" (normal c'est ce qu'on demandait) je l'ai donc enlevé puisque les entêtes sont déjà identifiées.
Donc si je recherche le nom de mon vétérinaire "ou" du client ça marche nickel, mais quand je veux ressortir les 2 il me met ce message d'erreur
Pièce jointe 406913

Ce qui m'emmène à 2 questions:
1 - Peut on travailler avec des noms de tableaux plutôt que les feuilles ?
2 - Peut on ressortir le Vet.Nom en A15 et Cli.Nom en A16 ou faut il faire 2 requêtes?

Merci encore pour ton aide

27/08/2018, 09h22
Invité
Il faut que le nom de tes onglets porte le.même nom que tes tables ou dans ta requête [Feulle1$] si ton onglet s'appel Feuille1
Code:

1 2 Dim Cn As object Set Cn = CreateOject("ADODB.Connection")

Bonjour,

Formulaire ajout/modif/sup en PJ

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Option Compare Text
Private Sub UserForm_Initialize()
  Me.enreg = [animaux].Rows.Count + 1
  Me.Id = Application.Max([animaux[id]]) + 1
  Me.Recherche.List = [animaux].Value
  Me.IdCli.List = [client].Value
  Me.IdVeto.List = [veto].Value
  Me.FamilleF.List = [Famille].Value
  Me.SexeF.List = [Sexe].Value
End Sub
 
Private Sub Recherche_Change()
  Me.enreg = Application.Match(Val(Me.Recherche), [animaux[id]], 0)
  Me.Id = Me.Recherche
  Me.Nom = [animaux].Item(enreg, 2)
  Me.FamilleF = [animaux].Item(enreg, 3)
  Me.RaceF = [animaux].Item(enreg, 4)
  Me.SexeF = [animaux].Item(enreg, 5)
  Me.IdCli = [animaux].Item(enreg, 6)
  Me.IdVeto = [animaux].Item(enreg, 7)
  Me.NomClient = Application.VLookup(Val(Me.IdCli), [client], 2, False)
  Me.NomVeto = Application.VLookup(Val(Me.IdVeto), [veto], 2, False)
End Sub
 
Private Sub FamilleF_Change()
  Race = [Race].Value
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(Race)
    If Race(i, 1) = Me.FamilleF Then d(Race(i, 2)) = ""
  Next i
  Me.RaceF.List = d.keys
End Sub
 
Private Sub IdVeto_click()
  Me.NomVeto = Me.IdVeto.Column(1)
End Sub
 
Private Sub IdCli_Click()
  Me.NomClient = Me.IdCli.Column(1)
End Sub
 
Private Sub B_valid_Click()
  enreg = Me.enreg
  [animaux].Item(enreg, 1) = Val(Me.Id)
  [animaux].Item(enreg, 2) = Me.Nom
  [animaux].Item(enreg, 3) = Me.FamilleF
  [animaux].Item(enreg, 4) = Me.RaceF
  [animaux].Item(enreg, 5) = Me.SexeF
  [animaux].Item(enreg, 6) = Val(Me.IdCli)
  [animaux].Item(enreg, 7) = Val(Me.IdVeto)
End Sub
 
Private Sub B_sup_Click()
  If MsgBox("Etes vous sûr de supprimer " & Me.Nom & "?", vbYesNo) = vbYes Then
     [animaux].Rows(Me.enreg).Delete
     Me.Recherche.List = [animaux].Value
  End If
End Sub
 
Private Sub B_ajout_Click()
  raz
  Me.Id = Application.Max([animaux[id]]) + 1
  Me.enreg = [animaux].Rows.Count + 1
End Sub
 
Sub raz()
  Me.Nom = ""
  Me.IdCli = ""
  Me.IdVeto = ""
  Me.FamilleF = ""
  Me.RaceF = ""
  Me.SexeF = ""
  Me.NomClient = ""
  Me.NomVeto = ""
End Sub

Boisgontier

27/08/2018, 09h57
Floyd-44

Citation:

Envoyé par dysorthographie

Il faut que le nom de tes onglets porte le.même nom que tes tables ou dans ta requête [Feulle1$] si ton onglet s'appel Feuille1

Oui le seul inconvénient c'est que sur ma feuille DetailAnimaux j'ai 3 tableaux:
Famille (chien, chat, etc..) avec une colonne "ID" et une "Famille"
Race (Epagnol, Malinois etc... avec une colonne "ID" et une "Race"
et pareil avec le tableau "Sexe"
Donc je me retrouve avec 3 entêtes "ID"
J'ai bien entendu la solution de créer des nouvelles feuilles mais j'ai lu ça dans la note de SilkyRoad:

Citation:

La gestion des tables:
Lors de la rédaction des requêtes, vous devez ajouter le symbole $ à la suite du nom des onglets (les tables), ce qui n'est pas le cas des plages de cellules nommées (aussi considérées comme des tables).

Alors ca me perd un peu.
27/08/2018, 10h44
Invité

Code:

Sql="Select Vet.Nom,Cli.Nom From [Animaux$A1:C120] Ani "
27/08/2018, 11h28
78chris

Bonjour

Une question en ADODB si on travaille sur le fichier en cours, cela prend-il bien les modifications en cours ou faut-il enregistrer le fichier ?

1 pièce(s) jointe(s)

Sinon un simple dictionnaire des deux tableaux n'aurait pas pu suffire ? :pastaper:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Base 1
Private Dico_User As New Dictionary
 
Private Sub TextBox1_Change()
 
If (Dico_User.Exists(TextBox1.Text)) Then Label1.Caption = Dico_User(TextBox1.Text) Else Label1.Caption = "ID non valide"
 
End Sub
 
Private Sub UserForm_Initialize()
Dim Tabl_User As ListObject, rs As ListRows
Dim Temp As Variant
Dim r As Double
 
Set Tabl_User = Worksheets("Feuil1").ListObjects("Tableau_Test")
Set rs = Tabl_User.ListRows
 
For r = 1 To rs.Count
 
    Temp = rs(r).Range.Value
    Dico_User.Add CStr(Temp(1, 1)), Temp(1, 2) & " " & Temp(1, 3)
 
Next r
 
Set Tabl_User = Nothing
Set rs = Nothing
 
End Sub

Pièce jointe 406953

bonjour 78chris,

oui si le fichier dispose d'un chemin d’accès Windows???

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub test()
Dim wb As Workbook
Set wb = Workbooks.Add
wb.SaveAs Environ("temp") & "\toto.xlsx"
With wb.Sheets(1)
    .Range("A1") = "Champ1"
    .Range("A2") = "toto"
End With
 
With CreateObject("ADODB.Connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & wb.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
     Set Rst = .Execute("select * from [" & wb.Sheets(1).Name & "$]")
     ThisWorkbook.Sheets(1).Range("A15").CopyFromRecordset Rst   'Ecrit le résultat de la requête dans la cellule A15
    .Close
End With
End Sub

@bonjour Al__22,

en fait une requête c'est comme un dictionnaire!, c'est moins évident de prime abord mais c'est une collection également et plus rapide!

27/08/2018, 12h16
Al__22

@dysorthographie

Je le savais mais je pense surtout à nos petits collègues qui eux pataugent complet quand on commence à leur parler de LINQ, ADODB, etc. ;)

Citation:

Envoyé par dysorthographie

Code:

Sql="Select Vet.Nom,Cli.Nom From [Animaux$A1:C120] Ani "

Je n'ai pas réussi mais j'arrive à mes fins avec :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub NameFinder()
  Dim Cn As ADODB.Connection
  Dim RstC As Object, RstV As Object
  Dim CSql As String, VSql As String, AniID As Integer
    AniID = AnMyRow.Range(1).Value
'Requête SQL pour retrouver le Nom Clients en fonction des ID.Cli dans la Feuille Animal
    CSql = " Select Cli.Nom From [Animal$] Ani "
    CSql = CSql & " Left Outer Join [Client$] Cli on Ani.IDCli = Cli.ID"
    CSql = CSql & " Where Ani.ID = " & AniID & " "
'Requête SQL pour retrouver le Nom Vétérinaires en fonction des ID.Vet dans la Feuille Veterinaire
    VSql = " Select Vet.Nom From [Animal$] Ani"
    VSql = VSql & " Left Outer Join [Veterinaire$] Vet on Ani.IDVet = Vet.ID"
    VSql = VSql & " Where Ani.ID = " & AniID & " "
'Lance les requêtes
  Set Cn = New ADODB.Connection
  With Cn
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
     Set RstC = .Execute(CSql)
     'Ecrit le nom du client dans la cellule XFD2
         Range("XFD2").CopyFromRecordset RstC
     Set RstV = .Execute(VSql)
     'Ecrit le nom du vétérinaire dans la cellule XFD3
         Range("XFD3").CopyFromRecordset RstV
     .Close
  End With
  Set Cn = Nothing
End Sub

Et avant ça, il y a ce code, appelé avec un Combobox Change, qui reprend les valeurs du tableau pour remplir le Userform (pour la modification de l'animal)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
Private Sub CboModif_Change()
  If CboModif.ListIndex <> -1 Then
    Set AnMyRow = Range("Animaux").ListObject.ListRows(CboModif.ListIndex + 1)
  End If
  AnValuesToControls
 
 
Sub AnValuesToControls()
  NameFinder
'Importer les données du tableau "Clients" dans le formulaire
  With AnMyRow   'ListRow
 
    TxtID.Value = .Range(1).Value
    TxtNom.Value = .Range(2).Value
    TxtIDCli.Value = .Range(3).Value
    TxtIDVet.Value = .Range(4).Value
    CboFam.Value = .Range(5).Value
    CboRace.Value = .Range(6).Value
    CboSexe.Value = .Range(7).Value
    TxtInfo.Value = .Range(8).Value
  End With
  With Sheets("Animal")
    CboMaitre.Value = Range("XFD2").Value
    CboVet.Value = Range("XFD3").Value
    Range("XFD2") = ""
    Range("XFD3") = ""
  End With
End Sub

Merci beaucoup pour ton aide

Voir 40 message(s) de cette discussion en une page