Formulaire ajout modif suppression
tableau dynamique
Cases options dynamiques avec ListBox
Filtre multi-colonnes
Recherche intuitive
Tri de tableaux dynamiques
Tri ListBox Options
Noms de tableaux dynamiques
BD Multi-tables
BD Employés/ jour de travail
Listes cascade X niveaux
Les avantages de la présentation Tableau:
-Pas besoin de spécifier la feuille
-Le tableau s'grandit automatiquement en hauteur & largeur)
-Si on ajoute une ligne, les formules sont recopiées
La référence aux différents éléments
d'un tableau dynamique est relative au tableau:
-Un tableau dynamique peut donc être déplacé sans
qu'il soit nécessaire de modifier la programmation des numéros
de colonne.
Exemples formules:
=NB.SI.ENS(Tableau1[CA];">15000")
=SOMME.SI.ENS(Tableau1[CA];Tableau1[CA];">15000")
=SOMME.SI.ENS(Tableau2[CA];Tableau2[Région];"ouest")
Avec Indirect
A2 contient le nom d'un tableau dynamique.
=SOMME.SI.ENS(INDIRECT(A2&"[Nb km]");INDIRECT(A2&"[Dates]");">="&$F$1;INDIRECT(A2&"[Dates]");"<="&$H$1)
Exemples VBA:
NbCol = [Tableau1].Columns.Count
' Nombre colonnes de la BD
TblBD = [Tableau1].Resize(, NbCol + 1).Value
' BD dans Array
Me.ComboTri.List = Application.Transpose([Tableau1].Offset(-1).Resize(1))
' Titres BD
[Tableau1].Rows(ligne).Delete
' Suppression ligne
[Tableau1].Item(ligne, Colonne) = tmp '
Ecriture dans la BD en ligne,colonne
n = [Tableau1].Rows.Count
' Nombre de lignes de la BD
TitreColonne2 = [Tableau1].Offset(-1).Item(1,2) ' Entête
de la colonne 2
TblNoms = [Tableau1[nom]]
' Colonne des noms dans TblNoms(,)
temp=[Tableau1[nom]].Item(1) '
Premier nom dans temp
Tbl = [tableau1[nom]] '
Colonne nom dans Array Tbl()
Tbl = [tableau1].Columns(2) '
Colonne 2 dans Array Tbl()
TblTout = Range("Tableau1[#all]") '
Tableau avec entete
TblTout = [Tableau1[#all]] '
Tableau avec entete
TblEntete = Range("Tableau1[#all]").Rows(1)
' en-tête tableau
MsgBox TblEntete(1, 2) '
Entête 2e colonne
TblEntete = [client[#headers]] '
Tableau en têtes
temp = TblEntete(1, 2)
temp = [client[#headers]].Item(2)
TblEntete = Range("Tableau1").ListObject.HeaderRowRange
MsgBox TblEntete(1, 2)
Tbl3col = Range("Tableau1[[nom]:Tableau1[ville]]") '
3 Colonnes adjacentes
NomFeuille = Range("Tableau1").Parent.Name
' nom de la feuille hôte
Set Rng = Range("Tableau1[nom], Tableau1[ville]")
' champs discontinus
MsgBox Rng.Areas(2)(1) '
1ere ville
LigneTableur = Range("client").Rows(LigneTableau).Row
' No ligne tableur
Syntaxe ListObject
TblBD =Sheets("bd").ListObjects(1).Range.Resize(,
3) '
BD dans un Array
n = Sheets("bd").ListObjects(1).DataBodyRange.Rows.Count
' Nombre de lignes
Tbl = Sheets("bd").ListObjects(1).HeaderRowRange
' Titres
Sheets("bd").ListObjects(1).DataBodyRange.Item(1, 1) = "Dupont"
Sheets("bd").ListObjects(1).ListRows.Add (1)
' Ajout d'une ligne en position 1
Sheets("bd").ListObjects(1).ListRows.Add
' Ajout d'une ligne en fin
Sheets("bd").ListObjects(1).DataBodyRange.Rows(2).Delete
' Suppression ligne 2
Tbl =Sheets("bd").ListObjects(1).DataBodyRange.Columns(1)
' Colonne 1 dans un Array
Sheets(bd").ListObjects(1).DataBodyRange.Delete
'
Suppression des données
Sheets("bd").ListObjects.Add(xlSrcRange,Range("A1").CurrentRegion,
, xlYes).Name = "Tableau2" 'création
Sheets("bd").ListObjects("Tableau2").TableStyle
= "TableStyleMedium15"
sheets("bd").ListObjects(1).ListRows.Add
' Ajout d'une ligne en fin
LigneTableur = Sheets("BD").ListObjects(1).ListRows(LigneTableau).Range.Row
' No ligne tableur
Opérations courantes sur les tableaux
Sub SuppressionLigneTableau()
n = 1
If [tableau1].Item(n, 1) <> "" Then [tableau1].Rows(n).delete
End Sub
Sub InsèreLigneTableau()
[tableau1].Rows(1).Insert
End Sub
Sub AjoutFinTableau()
If [tableau1].Item(1, 1) <> "" Then n =
[tableau1].Rows.Count + 1 Else n = 1
[tableau1[nom]].Item(n, 1) = "xxxx"
End Sub
Sub VideTableau()
If [tableau1].Item(1, 1) <> "" Then [tableau1].delete
End Sub
Recherche d'un matricule
Par formule:
=INDEX(Tableau1[Nom];EQUIV($G$1;Tableau1[Matricule];0))
=INDEX(Tableau1[Téléphone];EQUIV($G$1;Tableau1[Matricule];0))
Par VBA:
Sub RechercheNom()
matricule = 3
Position = Application.Match(matricule, [tableau1[matricule]],
False)
ville = [tableau1[nom]].Item(Position, 1)
Téléphone = [tableau1[téléphone]].Item(Position,
1)
End Sub
ou
Sub RechercheNom2()
nomtableau = "Tableau1"
matricule = 3
Position = Application.Match(matricule, Range(nomtableau).Columns(2),
False)
nom = Application.Index(Range(nomtableau).Columns(1), Position)
Téléphone = Application.Index(Range(nomtableau).Columns(3),
Position)
End Sub
Liste des tableaux
Function ListeTableaux()
Application.Volatile
ReDim Tbl(1 To Application.Caller.Rows.Count)
n = 0
For Each s In ActiveWorkbook.Sheets
For Each t In s.ListObjects
n = n + 1
Tbl(n) = t.Name
Next t
Next s
ListeTableaux = Application.Transpose(Tbl)
End Function
Formulaire ajout modif suppression tableau dynamique
Form
ajout modif sup tableau dynamique
Form
ajout modif sup tableau dynamique bis
Form
ajout modif sup tableau dynamique occurences
Form
ajout modif sup tableau dynamique 2
Form
ajout modif sup tableau dynamique 3
Option Compare Text
Private Sub UserForm_Initialize()
Me.enreg = [client].Rows.count + 1
Me.Id = Application.Max([client[id]]) + 1
Me.Recherche.List = [client].Value
End Sub
Private Sub Recherche_Change()
Me.enreg = Application.Match(Val(Me.Recherche), [client[id]],
0)
Me.Id = Me.Recherche
Me.Nom = [client].Item(enreg, 2)
Me.Rue = [client].Item(enreg, 3)
Me.Ville = [client].Item(enreg, 4)
Me.CodePostal = [client].Item(enreg, 5)
Me.Tph = [client].Item(enreg, 6)
Me.Portable = [client].Item(enreg, 7)
Me.Email = [client].Item(enreg, 8)
Me.Remarques = [client].Item(enreg, 9)
End Sub
Private Sub B_valid_Click()
enreg = Me.enreg
[client].Item(enreg, 1) = Val(Me.Id)
[client].Item(enreg, 2) = Me.Nom
[client].Item(enreg, 3) = Me.Rue
[client].Item(enreg, 4) = Me.Ville
[client].Item(enreg, 5) = Me.CodePostal
[client].Item(enreg, 6) = Me.Tph
[client].Item(enreg, 7) = Me.Portable
[client].Item(enreg, 8) = Me.Email
[client].Item(enreg, 9) = Me.Remarques
End Sub
Private Sub B_sup_Click()
If MsgBox("Etes vous sûr de supprimer "
& Me.Nom & "?", vbYesNo) = vbYes Then
[client].Rows(Me.enreg).Delete
End If
End Sub
Private Sub B_ajout_Click()
raz
Me.Id = Application.Max([client[id]]) + 1
Me.enreg = [client].Rows.count + 1
End Sub
Sub raz()
Me.Nom = ""
Me.Rue = ""
Me.Ville = ""
Me.CodePostal = ""
Me.Tph = ""
Me.Portable = ""
Me.Email = ""
Me.Remarques = ""
End Sub
Cases d'options dynamiques avec ListBox
Option Compare Text
Dim TblBD()
Private Sub UserForm_Initialize()
TblBD = [client].Value ' pour rapidité
TriMultiCol TblBD, 1, UBound(TblBD), 2
Set d = CreateObject("scripting.dictionary")
d("*") = ""
For i = 1 To [client].Rows.Count
tmp = TblBD(i, 4): d(tmp) = ""
Next i
Me.OptionsVille.ListStyle = 1 'frmliststyleoption
Tbl = d.keys
Tri Tbl, 1, UBound(Tbl)
Me.OptionsVille.List = Tbl
Me.ListBox1.ColumnCount = [client].Columns.Count + 1
Me.ListBox1.ColumnWidths = "20;50;80;50;30;70;70;50;50"
Me.ListBox1.List = TblBD
End Sub
Private Sub OptionsVille_Click()
tmp = Me.OptionsVille
Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
For i = 1 To UBound(TblBD)
If TblBD(i, 4) Like tmp Then
n = n + 1: ReDim Preserve
Tbl2(1 To Ncol, 1 To n)
For k = 1 To Ncol: Tbl2(k,
n) = TblBD(i, k): Next k
End If
Next i
If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
End Sub
Transfert d'une ListBox dans un Tableau
Private Sub B_recup2_Click()
Set f2 = Sheets("RésultatTableau")
f2.Cells.Clear
'--- création tableau
TblTitre = Range("Tableau1[#all]").Rows(1) ' on
prend les titres d'un autre tableau
f2.Cells(1, 1).Resize(, UBound(TblTitre, 2)) = TblTitre
TblBD = Me.ListBox1.List
f2.Cells(2, 1).Resize(UBound(TblBD), UBound(TblBD, 2) +
1) = TblBD
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").CurrentRegion,
, xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
End Sub
Autre méthode en ajoutant les enregistrements un par un, permettant ainsi de choisir les colonnes de la ListBox.
Private Sub b_recup_Click()
Set f2 = Sheets("RésultatTableau")
f2.Cells.Clear
'--- création tableau
TblTitre = Range("Tableau1[#all]").Rows(1)
f2.Cells(1, 1).Resize(, UBound(TblTitre, 2)) = TblTitre
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").Resize(,
UBound(TblTitre, 2)), , xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
'--- Transfert item par item
TblBD = Me.ListBox1.List
For i = LBound(TblBD) To UBound(TblBD)
f2.ListObjects(1).ListRows.Add ' Ajout
d'une ligne en fin
For c = 0 To UBound(TblBD, 2)
f2.ListObjects(1).DataBodyRange.Item(i
+ 1, c + 1) = TblBD(i, c)
Next c
Next i
End Sub
Liste des tableaux d'un classeur
For s = 1 To Sheets.Count
For Each n In Sheets(s).ListObjects
MsgBox n.Name
Next n
Next s
Cases d'option dynamiques avec ListBox
Cases
d'options avec ListBox
Cases d'options
avec ListBox Choix Col Visu
La propriété ListStyle
du ListBox est positionnée à ListStyleOption.
Sur l'exemple, le programme s'adapte automatiquement à
la BD.
Pour Excel<2007
Set f = Sheets("bd") ' Pour Excel<Excel 2007
Set Rng = f.Range("A2:G" & f.[A65000].End(xlUp).Row) '
à adapter
NomTableau = "Tableau1"
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng
Dim TblBD(), NbCol
Private Sub UserForm_Initialize()
NbCol = [Tableau1].Columns.Count
TblBD = [Tableau1].Resize(, NbCol).Value ' Array: + rapide
Me.ListBox1.List = TblBD
EnteteListBox1
'--- construction des cases d'options villes
Set d = CreateObject("scripting.dictionary")
For Each c In [Tableau1[Ville]]: d(c.Value) = "":
Next c
d("*") = ""
temp = d.keys
Tri temp, LBound(temp), UBound(temp)
Me.ListBox2.List = temp ' Villes triées
End Sub
Private Sub ListBox2_Click()
Dim TblDest()
n = 0
For i = 1 To UBound(TblBD)
If TblBD(i, 3) Like Me.ListBox2 Then
n = n + 1: ReDim Preserve
TblDest(1 To UBound(TblBD, 2), 1 To n)
For k = 1 To NbCol : TblDest(k,
n) = TblBD(i, k): Next k
End If
Next i
Me.ListBox1.Column = TblDest
End Sub
Autre écriture - sans TblBD() - mais moins rapide
Private Sub ListBox2_Click()
Dim TblDest(): n = 0
NlignesBD = [Tableau1].Rows.Count
For Each c In [Tableau1[Ville]]
If c Like Me.ListBox2 Then
n = n + 1: ReDim Preserve TblDest(1
To NlignesBD, 1 To n)
For k = 1 To NbCol: TblDest(k, n)
= c: Next k
End If
Next c
Me.ListBox1.Column = TblDest
End Sub
Sur l'exemple, le programme
s'adapte automatiquement à la BD jusqu'à 24 colonnes.
Au delà, ajouter TextBox25,TextBox26,..Label25,Label26,...
Les champs peuvent être positionnés manuellement sur le
formulaire.
-Un combobox permet de choisir la colonne de recherche
-Un comboxox permet de choisir la colonne de tri du ListBox
-Des TextBoxs permettent de modifier la BD
-pour modifier manuellement l'écran de saisie,
supprimer l'appel de LabelsTextBox
Filtre
ListBox avec tableau dynamique
Filtre
ListBox avec tableau dynamique Choix Col Visu
Pour Excel<2007
Set f = Sheets("bd") ' pour versions Excel <2007
Set Rng = f.Range("A2:V" & f.[A65000].End(xlUp).Row) '
pour versions Excel <2007
ActiveWorkbook.Names.Add Name:="Tableau1", RefersTo:=Rng 'pour
versions Excel <2007
Filtres multi-colonnes dur tableau dynamique
Filtre
multi-colonnes choix colonne filtre tableau dynamique
Filtre
multi-colonnes choix colonne filtre tableau dynamique Intuitif
Form
Filtre 6 ComboBoxs tableau dynamique
Form
Filtre 6 ComboBoxs tableau dynamique multi-pages
Form
Filtre 6 ComboBoxs tableau dynamique multi-pages2
Form
Filtre 6 ComboBoxs tableau dynamique multi-pages Calculs
Form
Filtre 6 ComboBoxs tableau dynamique Scroll Frame
Recherche intuitive sur tableau dynamique
Form
recherche intuitive multi-mots multi-colonnes ComboBox tableur
Form
recherche intuitive multi-mots multi-colonnes ComboBoxForm
Filtre dans comboBox & recherche intuitive sur textBox
Choix ComBox & recherche intuitive sur nom
Autres exemples
Form
recherche intuitive multi-mots multi-colonnes Mini
Form
recherche intuitive tableau dynamique Ajout Modif
Form
recherche intuitive tableau dynamique multi-pages Ajout Modif
Form
recherche intuitive tableau dynamique Scroll Frame Ajout Modif
Form
recherche intuitive tableau dynamique multi-BD ajout Modif
Form
Fournisseurs produits multi-BD Ajout Modif
Form
recherche intuitive tableau dynamique élèves Ajout Modif
Form
recherche intuitive tableau dynamique Frame élèves Ajout
Modif
Tri d'un tableau dynamique
Option Compare Text
Sub TriTableau1()
ColTri = 1
NomTableau = "Tableau1"
Range(NomTableau).Sort Key1:=Range(NomTableau).Cells(1,
ColTri), Order1:=xlAscending, Header:=xlGuess
End Sub
Tri par ville
[tableau1].Sort Key1:=[tableau1[ville]], Order1:=xlAscending, Header:=xlGuess
Noms de tableaux dynamiques
Sub NomsTableaux()
For s = 1 To Sheets.Count
For Each n In Sheets(s).ListObjects
tmp = tmp & "/"
& n.Name
Next n
Next s
MsgBox tmp
End Sub
Formulaire de tri
Private Sub UserForm_Initialize()
For s = 1 To Sheets.Count
For Each n In Sheets(s).ListObjects
Me.ComboBox1.AddItem n.Name
Next n
Next s
End Sub
Private Sub ComboBox1_click()
Tbl = Application.Transpose(Range(Me.ComboBox1).Offset(-1).Rows(1).Value)
Me.ComboBox2.List = Tbl
End Sub
Private Sub b_ok_Click()
Tbl = Application.Transpose(Range(Me.ComboBox1).Offset(-1).Rows(1).Value)
colTri = Application.Match(Me.ComboBox2, Tbl, 0)
Tri Me.ComboBox1, colTri
End Sub
Sub Tri(NomTableau, colTri)
Range(NomTableau).Sort Key1:=Range(NomTableau).Cells(1, colTri), Order1:=xlAscending,
Header:=xlGuess
End Sub
Raz tableau dynamique
Sub RazTableau()
NomTableau = "Tableau3"
n = Range(NomTableau).Rows.Count
If n > 1 Then Range(NomTableau).Rows(2).Resize(n - 1).Delete
End Sub
Récupération des clés et des items d'un dictionnaire dans un tableau
Sub TransfertDicoTableau()
NomTableau = "Tableau3"
n = Range(NomTableau).Rows.Count
If n > 1 Then Range(NomTableau).Rows(2).Resize(n - 1).Delete
Set d = CreateObject("scripting.dictionary")
For i = 1 To 100: d(i) = i * i: Next i
Range(NomTableau).Columns(1).Resize(d.Count) = Application.Transpose(d.keys)
Range(NomTableau).Columns(2) = Application.Transpose(d.items)
End Sub
Tri ListBox avec boutons d'options
Tri ListBox
Options
Tri ListBox Options
Dynamique
BD Multi-tables
Option Compare Text
Private Sub UserForm_Initialize()
Me.enreg = [animaux].Rows.Count + 1
Me.Id = Application.Max([animaux[id]]) + 1
Me.Recherche.List = [animaux[Id]:animaux[Nom]].Value
Me.IdCli.List = [client[Id]:client[Nom]].Value
Me.IdVeto.List = [veto[Id]:veto[Nom]].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
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
BD Employés-Activité
Option Compare Text
Private Sub UserForm_Initialize()
Me.enreg = [Employés].Rows.Count + 1
Me.Id = Application.Max([employés[id]]) + 1
Me.Recherche.List = [Employés[Id]:Employés[Nom]].Value
Me.textbox4.List = [typeActivité].Value
Jour_Activité
End Sub
Private Sub Recherche_Change()
Me.enreg = Application.Match(Val(Me.Recherche), [employés[id]],
0)
Me.Id = Me.Recherche
Me.Nom = [Employés].Item(enreg, 2)
Me.Rue = [Employés].Item(enreg, 3)
Me.Ville = [Employés].Item(enreg, 4)
Me.CodePostal = [Employés].Item(enreg, 5)
Me.Tph = [Employés].Item(enreg, 6)
Me.Portable = [Employés].Item(enreg, 7)
Me.Email = [Employés].Item(enreg, 8)
Me.Remarques = [Employés].Item(enreg, 9)
Me.Service = [Employés].Item(enreg, 10)
Jour_Activité
End Sub
Sub Jour_Activité()
Dim TblJour()
Ncol = [Employés].Columns.Count
For i = 1 To [Activité].Rows.Count
If Val(Me.Id) = [Activité].Item(i,
1) Then
n = n + 1: ReDim Preserve
TblJour(1 To Ncol - 1, 1 To n)
TblJour(1, n) = [Activité].Item(i,
2)
TblJour(2, n) = Format([Activité].Item(i,
3), "hh:mm")
TblJour(3, n) = Format([Activité].Item(i,
4), "hh:mm")
TblJour(4, n) = [Activité].Item(i,
5)
TblJour(5, n) = i
End If
Next i
If n > 0 Then Me.ListBox1.Column = TblJour Else
Me.ListBox1.Clear
Me.EnregJT = [Activité].Rows.Count + 1
End Sub
Private Sub B_valid_Click()
enreg = Me.enreg
[Employés].Item(enreg, 1) = Val(Me.Id)
[Employés].Item(enreg, 2) = Me.Nom
[Employés].Item(enreg, 3) = Me.Rue
[Employés].Item(enreg, 4) = Me.Ville
[Employés].Item(enreg, 5) = Me.CodePostal
[Employés].Item(enreg, 6) = Me.Tph
[Employés].Item(enreg, 7) = Me.Portable
[Employés].Item(enreg, 8) = Me.Email
[Employés].Item(enreg, 9) = Me.Remarques
[Employés].Item(enreg, 10) = Me.Service
Me.Recherche.List = [Employés].Value
End Sub
Private Sub B_sup_Click()
If MsgBox("Etes vous sûr de supprimer "
& Me.Nom & "?", vbYesNo) = vbYes Then
For i = 1 To [jourtravail].Rows.Count
If Val(Me.Id) = [jourtravail].Item(i,
1) Then [jourtravail].Rows(i).Delete
Next i
[Employés].Rows(Me.enreg).Delete
Me.Recherche.List = [Employés].Value
End If
End Sub
Private Sub B_ajout_Click()
raz
Me.Id = Application.Max([employés[id]]) + 1
Me.enreg = [Employés].Rows.Count + 1
Jour_Travail
End Sub
Sub raz()
Me.Nom = ""
Me.Rue = ""
Me.Ville = ""
Me.CodePostal = ""
Me.Tph = ""
Me.Portable = ""
Me.Email = ""
Me.Remarques = ""
End Sub
Private Sub ListBox1_Click()
For i = 1 To 4
Me("textbox" & i) = Me.ListBox1.Column(i
- 1)
Next i
Me.EnregJT = Me.ListBox1.Column(4)
End Sub
Private Sub BSF_Valid_Click()
enreg = Me.EnregJT
[Activité].Item(enreg, 1) = Val(Me.Id)
[Activité].Item(enreg, 2) = Me("textbox"
& 1)
[Activité].Item(enreg, 3) = TimeValue(Me("textbox"
& 2))
[Activité].Item(enreg, 4) = TimeValue(Me("textbox"
& 3))
[Activité].Item(enreg, 5) = Me("textbox"
& 4)
Jour_Activité
End Sub
Private Sub BSF_Ajout_Click()
Me.EnregJT = [Activité].Rows.Count + 1
For i = 1 To 4
Me("textbox" & i) = ""
Next i
End Sub
Private Sub BSF_Sup_Click()
If MsgBox("Etes vous sûr de supprimer "
& Me.TextBox1 & "?", vbYesNo) = vbYes Then
[Activité].Rows(Me.EnregJT).Delete
Jour_Activité
End If
End Sub
Liste cascade X niveaux
Le nombre de niveaux est paramétré.
Cascade
x niveaux horizontal
Cascade
x niveaux vertical
Dim zSaisie, NbNiv
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set zSaisie = Range("B2:G4")
NbNiv = 6
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count
= 1 Then
TblBD = [Tableau1].Value
Set d1 = CreateObject("Scripting.Dictionary")
nivCourant = Target.Column - zSaisie.Column
+ 1
Dim Tmp(): ReDim Tmp(1 To nivCourant)
For k = 1 To nivCourant - 1
Tmp(k) = Target.Offset(, -(nivCourant
- k))
Next k
For i = 1 To UBound(TblBD)
témoin = True
For k = 1 To nivCourant
- 1
If TblBD(i,
k) <> Tmp(k) Then témoin = False: Exit For
Next k
If témoin Then
d1(TblBD(i, nivCourant)) = ""
Next i
If d1.Count > 0 Then
temp = Join(d1.keys, ",")
Target.Validation.Delete
If temp <>
"" Then Target.Validation.Add xlValidateList, Formula1:=temp
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(zSaisie, Target) Is Nothing And Target.Count
= 1 Then
nivCourant = Target.Column - zSaisie.Column
+ 1
If nivCourant < NbNiv Then
Application.EnableEvents = False
Target.Offset(, 1).Resize(, NbNiv
- nivCourant).Validation.Delete
Target.Offset(, 1).Resize(, NbNiv
- nivCourant) = ""
Application.EnableEvents = True
End If
End If
End Sub
Filtre avancé avec les tableaux structurés
Sub Extrait()
[BD[#All]].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[Critère[#All]],
CopyToRange:=Sheets( "résultat").[A1:C1]
End Sub