|
Accueil
La commande Données/Validation permet de:
- Vérifier à la saisie si des valeurs sont correctes
- Créer des menus déroulant pour faciliter la saisie
Nombres entiers
Imposer la saisie de nombres compris entre 2 valeurs
-Sélectionner le champ B2:B6
-Données/Validation/Nombre entiers
-Spécifier un nombre compris entre 100 et 200 par exemple.
Listes
Créer une liste déroulante
- Sélectionner B2:B11
- Données/Validation
- Choisir Liste
- Cliquer dans Source puis champ F2:F6
DV synthèse
Liste sur un autre onglet ou classeur
La liste doit être nommée (ListeServices sur l'exemple)
-Sélectionner B2
-Données/Validation/Liste
-Dans Source =ListeServices
Si la liste est sur un autre classeur ouvert X.XLS
Solution1
Créer un nom de champ:
-Insertion/Nom/Définir: Liste
=Feuil1!$A$1:$A$6
-Dans Données/Validation/Liste: =Liste
Solution2
Si une nom MaListe existe déjà dans X.XLS
Créer un nom de champ:
-Insertion/Nom/Définir: Liste
=X.XLS!MaListe
-Dans Données/Validation/Liste: =Liste
Solution3
Si la cellule C2 contient X.XLS!Maliste
-Données/Validation: =INDIRECT(C2)
Avec classeur fermé
-Les données sont dans un classeur fermé DVSource.XLS dans un champ nommé ListeNoms
-Créer une liaison avec le champ ListeNoms de DVSource.xls
. Sélectionner A2:A20
.='C:\mesdoc\excel\fichiers\donneesValidation\DVSource.xls'!listeNoms
.Valider avec Maj+ctrl+entrée
.Dans Edition/Liaisons, modifier l'invite de démarrage Ne pas afficher l'alerte et mettre à jour la liaison
DvClasseurFerméLiaison
DvSource
Liste dynamique
Si des éléments sont ajoutés à une liste, créer un nom de champ dynamique.
=DECALER($A$2;;;NBVAL($A:$A)-1)
Liste horizontale
Une liste peut être horizontale
Ouvre une liste lorsque la cellule est sélectionnée
La liste est ouverte lorsque la cellule A2 est sélectionnée.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
SendKeys "%{down}"
End If
End Sub
Ci dessous, la liste est ouverte lorsque la cellule A2 est sélectionnée et la cellule est initialisée avec la première valeur de la liste.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
SendKeys "%{down}"
If Target = "" Then
Target = Range("Liste")(1)
End If
End If
End Sub
Choix obligatoire à l'ouverture du classeur
DVChoixObligatoireOuverture
Ouvre une liste de validation lorsque la cellule est survolée
Avec la boîte à outils Contrôles:
-Créer dans la cellule B2 un label Label1 avec A.
-Modifier la propriété BackStyle avec Transparent.
DvSurvol
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
.Select
SendKeys "%{down}"
End Sub
Pour obtenir une liste plus large que la colonne
-Elargir la colonne
-Faire la liste
-Rétrécir la colonne
DvLargeur
Listes conditionnelles
Le choix de la liste dépend d'une valeur
La liste en colonne B dépend de la valeur en colonne A (H/F)
-Données/Validation/Liste
=SI($A2="H";ListeH;ListeF)
ListCond
Le choix de la liste dépend du jour et de l'heure
=DECALER(liste;0;EQUIV(A1;dates;0)-1+--(A3>0,5))
ListCondJourHeure
Liste disponible les jours ouvrés
La liste des congés (C,M,...) n'est disponible que les jours ouvrés.
PlanningListeCondition
-Données/Validation/Liste
=SI(JOURSEM(B$6;2)<6;liste;)
Décocher Ignorer si vide
Récupération de la couleur d'une liste
La couleur est modifiée après le choix dans la liste.
DvListeRecupCouleur
DvJourDemiJour
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
On Error Resume Next
Target.Interior.ColorIndex = .Find(Target, LookAt:=xlWhole).Interior.ColorIndex
End If
End Sub
On peut obtenir le nom de la liste de Données/Validation automatiquement avec.
NomListe = Mid(Target.Validation.Formula1, 2)
Target.Interior.ColorIndex = Sheets("liste").Range(NomListe).Find(Target, LookAt:=xlWhole).Interior.ColorIndex
Pour une sélection multiple
-Sélectionner les cellules avec Ctrl
-Choisir dans la liste
DVSelectMult
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
Application.EnableEvents = False
Selection.Value = Target
Application.EnableEvents = True
On Error Resume Next
Selection.Interior.ColorIndex = .Find(Target, LookAt:=xlWhole).Interior.ColorIndex
End If
End Sub
Récupération du format
DvListeRecupCouleur2
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
.Find(Target, LookAt:=xlWhole).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.EnableEvents = True
End If
End Sub
Récupération de la mise en forme
DvExposant
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B5], Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
.Find(Target, LookAt:=xlWhole).Copy Target
Target.Validation.Add xlValidateList, Formula1:="=Liste"
Application.EnableEvents = True
End If
End Sub
Autres exemples avec police Wingdings
Wingdings
Wingdings Boutons
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B5], Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
.Find(Target, LookAt:=xlWhole).Offset(, 1).Copy Target
Application.EnableEvents = True
End If
End Sub
Choix dans un combobox
Wingdings Combo
Récupération d'un commentaire
RecupCommentaire
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$2" Then
Application.EnableEvents = False
.Find(Target, LookAt:=xlWhole).Copy
Target.PasteSpecial Paste:=xlPasteComments
Application.EnableEvents = True
End If
End Sub
Le commentaire peut contenir une image.
DVComment
Autre exemple
On récupère en commentaire la cellule à droite du nom du fournisseur.
DVCommentaire2
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([D2:D100], Target) Is Nothing And Target.Count = 1 Then
Application.EnableEvents = False
temp = .Find(Target, LookAt:=xlWhole).Offset(, 1).Value
On Error Resume Next
Target.Comment.Delete
Target.AddComment
Target.Comment.Text Text:=CStr(temp)
Target.Comment.Shape.TextFrame.AutoSize = True
Application.EnableEvents = True
End If
End Sub
Mot de passe pour saisie
DVMP
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("B2:B2"), Target) Is Nothing Then
mp = InputBox("Mot de passe?")
If mp <> "toto" Then .Select
End If
End Sub
On récupère la colonne de droite
DVColonneDroite
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B10], Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
Target = .Find(Target).Offset(, 1).Value
Application.EnableEvents = True
End If
End Sub
Liste en couleur
FormColoriage2
Code formulaire
Dim Lbl(1 To 10) As New ClasseLabel
Private Sub UserForm_Initialize()
For i = 1 To 8
Me("Label" & i).BackColor = Sheets("couleurs").Cells(i, 1).Interior.Color
Me("Label" & i).ForeColor = Sheets("couleurs").Cells(i, 1).Font.Color
Me("Label" & i).Caption = Sheets("couleurs").Cells(i, 1)
Set Lbl(i).GrLabel = Me("Label" & i)
Next i
End Sub
Module de classe ClasseLabel
Public WithEvents GrLabel As Msforms.Label
Private Sub GrLabel_Click()
Selection.Interior.Color = GrLabel.BackColor
Selection.Font.Color = GrLabel.ForeColor
Selection.Value = GrLabel.Caption
End Sub
Liste en couleur avec ListBox
ListBoxSimuleClasse
ListBoxSimuleClasseSansClasse
Liste en couleur avec ListView
ListeCouleur
Simulation de la flèche pour données/validation/liste
Pour faire apparaître en permanence des flèches pour Données/Validation/Liste.
Le menu est ouvert automatiquement lorsque l'opérateur clique sur la flèche.
DVListeFlèche
DVListeFlècheGaucher
Sub fleche()
Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Offset(, -1).Select
SendKeys "%{down}"
End Sub
-Pour récupérer la flèche: clic-droit/copier-coller
-Pour affecter la macro: clic-droit/affecter une macro
Pour créer les flèches automatiquement
DVListeFlèche2
Sub AffecteFlèche()
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
ActiveSheet.Shapes("flèche").Copy
c.Offset(, 1).Select
ActiveSheet.Paste
Selection.Name = c.Address
Selection.Left = c.Offset(, 1).Left
Selection.Top = c.Offset(, 1).Top + 1
Selection.Height = c.Offset(, 1).Height
Selection.OnAction = "clicFlèche"
Next c
End Sub
Sub ClicFlèche()
Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Offset(, -1).Select
SendKeys "%{down}"
End Sub
Sub SupFlèches()
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
ActiveSheet.Shapes(c.Address).Delete
Next c
End Sub
Sur cette version, les flèches sont générées à l'aide de shapes
DVListeFlèche3
Choix dans un formulaire
L'opérateur sélectionne le champ puis choisit le type de tâche;
MFCPlus3CouleursForm
Private Sub UserForm_Initialize()
Me.ComboBox1.List = .Value
Me.ComboBox1.ListIndex = 0
End Sub
Private Sub ComboBox1_Change()
If Me.ComboBox1.ListIndex <> 0 Then
On Error Resume Next
.Find(Me.ComboBox1, LookAt:=xlWhole).Copy
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
Me.ComboBox1.ListIndex = 0
End If
End Sub
Choix dans un formulaire (longueur de liste>8)
Pour obtenir une liste de choix supérieure à 8 éléments, le choix se fait dans un combobox.
DVForm
DVFormPays
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 And Target.Count = 1 Then
UserForm1.Top = Target.Top + 110 - Cells(ActiveWindow.ScrollRow, 1).Top
UserForm1.Left = 150
UserForm1.Show
End If
Cancel = True
End Sub
Private Sub UserForm_Initialize()
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
ActiveCell.Value = Me.ComboBox1
Unload Me
End Sub
Choix dans un formulaire :Liste triée
DVFormTrié
Private Sub UserForm_Initialize()
Dim temp()
Set f = Sheets("feuil1")
temp = Application.Transpose(f.Range("H2:H" & f..End(xlUp).Row))
Call tri(temp, LBound(temp), UBound(temp))
Me.ComboBox1.List = temp
End Sub
Sub tri(a(), gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
Choix dans un formulaire (le champ de la liste a plusieurs colonnes)
DVFormChamp
Private Sub UserForm_Initialize()
Set mondico = CreateObject("Scripting.Dictionary")
a = .Value ' tableau a(,)
For Each c In a
mondico(c) = ""
Next c
Me.ComboBox1.List = mondico.keys
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
ActiveCell = Me.ComboBox1
Unload Me
End Sub
Coloriage de la ligne
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
On Error Resume Next
Cells(Target.Row, 1).Resize(, 4).Interior.ColorIndex = .Find(Target, LookAt:=xlWhole).Interior.ColorIndex
End If
End Sub
ColoriageLigne
Historique des modifications
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 2 And Target.Count = 3 Then ' colonne 3 seulement
If Target.Comment Is Nothing Then Target.AddComment ' Création commentaire
Target.Comment.Text Text:=Target.Comment.Text & _
Target.Value & " Modifié par:" & Environ("UserName") & " Le " & Now & vbLf
Target.Comment.Shape.TextFrame.AutoSize = True
End If
Application.EnableEvents = True
End Sub
Récupération des 3 premiers caractères
L'option Quand les données non valides sont frappées doit être décochée.
Dv3premierCaractères
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing Then
Application.EnableEvents = False
Target = Left(Target, 3)
Application.EnableEvents = True
End If
End Sub
Validation d'un planning par un superviseur
Suivant le nom de l'utilisateur, on fait apparaître la liste CouleursV(superviseur) ou Couleurs.
- PlanningSuperviseur -
Une fonction personnalisée NomUtil() permet de récupérer en A4 le nom de l'utilisateur
Function NomUtil()
NomUtil = Environ("username")
End Function
En B6:
-Données/Validation/Liste
=SI($A$4="Boisgontier";CouleursV;couleurs)
Pour modifier la couleur après le choix:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
If NomUtil() = "Boisgontier" Then
On Error Resume Next
Target.Interior.ColorIndex = Sheets("couleurs")..Find(Target, LookAt:=xlWhole).Interior.ColorIndex
Else
On Error Resume Next
Target.Interior.ColorIndex = Sheets("couleurs")..Find(Target, LookAt:=xlWhole).Interior.ColorIndex
End If
End If
End Sub
Saisie une seule fois
Au départ les cellules B2:B13 sont déverouillées.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B13], Target) Is Nothing And Target.Count = 1 Then
ActiveSheet.Unprotect
Target.Locked = True
Target.Interior.ColorIndex = 44
ActiveSheet.Protect
End If
End Sub
Choix successifs dans un menu
Les choix s'ajoutent ou se retranchent si choix déjà fait.
DV ChoixSuccessifs - DV ChoixSuccessifs2
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" And Target.Count = 1 Then
Application.EnableEvents = False
ValSaisie = Target
Application.Undo
p = InStr(Target, ValSaisie)
If p > 0 Then
Target = Left(Target, p - 1) & Mid(Target, p + Len(ValSaisie) + 1)
If Right(Target, 1) = ":" Then
Target = Left(Target, Len(Target) - 1)
End If
Else
If Target = "" Then
Target = ValSaisie
Else
Target = Target & ":" & ValSaisie
End If
End If
Application.EnableEvents = True
End If
End Sub
En remplaçant ':' par chr(10), l'affichage des noms se fait en colonne.
Liste avec 2 colonnes
Solution1: avec colonne intermédiaire
-Concaténer les 2 colonnes D et E dans la colonne F
-Créer un nom de champ MaListe
=DECALER($F$2;;;NBVAL($D:$D)-1)
Pour récupérer le code seulement:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B10], Target) Is Nothing And Target.Count = 1 Then
Application.EnableEvents = False
Target = Left(Target, InStr(Target, " ") - 1)
Application.EnableEvents = True
End If
End Sub
DV2colonnesConcat
Solution 2 : sans colonne intermédiaire
-Créer un nom de champ MaListe avec 1 colonne
=DECALER(Feuil1!$D$2;;;NBVAL(Feuil1!$D:$D)-1;1)
-Créer le menu avec Données/Validation/Liste =Maliste
-Modifier le nom de champ (2 colonnes)
=DECALER($D$2;;;NBVAL($D:$D)-1;2)
- DV 2 colonnes -
Avec 3 colonnes
Pour obliger la saisie d'un nom de la première colonne de la liste
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B10], Target) Is Nothing And Target.Count = 1 Then
p = Application.Match(Target, Application.Index(, , 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
End Sub
Pour récupérer le nom et le prénom dans la même cellule
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B10], Target) Is Nothing And Target.Count = 1 Then
p = Application.Match(Target, Application.Index(, , 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Else
Application.EnableEvents = False
Target.Value = Target.Value & " " & Application.Index(, p, 2)
Application.EnableEvents = True
End If
End If
End Sub
Pour récupérer le nom et le prénom dans 2 cellules
DV 2 colonnesNomPrenom
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B10], Target) Is Nothing And Target.Count = 1 Then
p = Application.Match(Target, Application.Index(, , 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Else
Application.EnableEvents = False
Target.Offset(, 1).Value = Application.Index(, p, 2)
Application.EnableEvents = True
End If
End If
End Sub
On choisi le libellé et on récupère le code
DvRecupCode
DvRecupCode2
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A2:A10], Target) Is Nothing Then
Application.EnableEvents = False
On Error Resume Next
Target = .Find(what:=Target).Offset(, 1)
Application.EnableEvents = True
End If
End Sub
On récupère la ville seulement
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
Application.EnableEvents = False
Target = Mid(Target, 7)
Application.EnableEvents = True
End If
End Sub
L'opérateur choisit le produit. Le prix est affiché dans la cellule
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
p = Application.Match(Target, Application.Index(, , 1), 0)
If IsError(p) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Else
Application.EnableEvents = False
Target.Value = Application.Index(, p, 2)
Application.EnableEvents = True
End If
End If
End Sub
Devis
Les prix sont différents pour les particuliers et les revendeurs.
-Le choix Particulier/Revendeur se fait en A2
-Le choix du code article se fait en A6
En C6, on obtient le prix avec
=SI(A6<>"";INDEX(Prix;EQUIV(A6;Articles;0);EQUIV($A$2;catégorie;0));0)
Devis
Choix d'un nom avec doublons
Nom de champ
BD =DECALER($E$2;;;NBVAL(Feuil1!$E:$E);2)
NomsAvecDoublons
NomsAvecDoublons2
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
UserForm1.Left = 100 + Target.Left
UserForm1.Top = 100 + Target.Top - Cells(ActiveWindow.ScrollRow, 1).Top
UserForm1.Show
End If
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.List = .Value
SendKeys "{F4}"
End Sub
Private Sub ComboBox1_Change()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(, 1) = Me.ComboBox1.Column(1)
Unload Me
End Sub
Affichage de plusieurs colonnes avec un formulaire
Facture
Facture Pharmacie
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 - Cells(ActiveWindow.ScrollRow, 1).Top
UserForm1.Show
End If
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.List = .Value
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
Liste des 7 jours suivants
On veut la liste des dates des 7 jours suivants la date du jour.
DV7joursSuivants
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" Then
temp = ""
d = Date
Do While d < Date + 7
temp = temp & Format(d, "ddd dd mmm yy") & ","
d = d + 1
Loop
On Error Resume Next
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Positionnement sur une colonne
Les titres des colonnes ne sont pas contigus.
DVColonne
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
temp = ""
For c = 1 To 5
temp = temp & Cells(1, c * 2 + 3) & ","
Next c
On Error Resume Next
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
Rows("1:1").Find(What:=Target.Value, LookIn:=xlValues).Select
End If
End Sub
Listes en cascade
On veut sélectionner un produit de remplacement dans une liste en cascade
DV CascadeProdRempl -
Créer le nom de champ:
Produits: =DECALER(Produits!$A$2;;;NBVAL(Produits!$A:$A)-1)
Pour obtenir la liste des produits sans doublons:
-Sélectionner F2:F9
=INDEX(Produits;PETITE.VALEUR(SI(EQUIV(Produits;Produits;0)=LIGNE(INDIRECT("1:"&LIGNES(Produits)));
EQUIV(Produits;Produits;0);"");LIGNE(INDIRECT("1:"&LIGNES(Produits)))))
-Valider avec Maj+ctrl+Entrée
Créer les noms de champ:
ListeProduits : =DECALER(Produits!$F$2;;;NB.SI(Produits!$F$2:$F$9;"<>#NOMBRE!"))
Remplacement : =DECALER(Produits!$B$2;;;NBVAL(Produits!$B:$B)-1;3)
Pour créer le menu en cascade:
Données/Validation/Liste
=DECALER(remplacement;EQUIV(B9;Produits;0)-1;0;NB.SI(Produits;B9))
Attention! Il faut d'abord créer le nom de champ Remplacement avec 1 colonne
=DECALER(Produits!$B$2;;;NBVAL(Produits!$B:$B)-1;1)
-Créer le menu en cascade
-Mettre 3 colonnes dans le nom de champ
Ajout dans une liste Données/Validation(Liste dynamique)
Si l'élément frappé n'appartient pas à la liste, il est ajouté à la iste dans le tableur.
Dans l'onglet Alerte Erreur, décocher Quand les données valides sont frappées.
DV_ajoutListe.xls
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Count = 1 Then
If Target <> "" Then
If IsError(Application.Match(Target.Value, , 0)) Then
If MsgBox("On ajoute?", vbYesNo) = vbYes Then
.End(xlDown).Offset(1, 0) = Target.Value
Sheets("Liste")..Sort key1:=Sheets("Liste").Range("A2")
Else
Application.Undo
End If
End If
End If
End If
End Sub
Liste automatique avec les items de la colonne
Affiche les items d'une colonne sur le clic dans la première cellule vide des colonnes B,C.
SendKeys
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Column = 2 Or Target.Column = 3) And Target.Count = 1 Then
If Target = "" Then SendKeys "%{down}"
End If
End Sub
Liste avec les items de la colonne et formulaire
La liste est alimentée par les valeurs déjà saisies. On peut ajouter de nouveaux items.
DVAjouFom
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 And Target.Count = 1 Then
UserForm1.Top = Target.Top + 110 - Cells(ActiveWindow.ScrollRow, 1).Top
UserForm1.Left = 150
UserForm1.Show
End If
Cancel = True
End Sub
Private Sub CommandButton1_Click()
ActiveCell.Value = Me.ComboBox1
Unload Me
End Sub
Private Sub UserForm_Initialize()
Set mondico = CreateObject("Scripting.Dictionary")
For Each c In Range("A2:A" & .End(xlUp).Row)
mondico(c.Value) = c.Value
Next c
Me.ComboBox1.List = mondico.items
SendKeys "{F4}"
End Sub
Liste sans vides
-Sélectionner C2
=INDEX(champ;PETITE.VALEUR(SI(champ<>"";LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1)))
-Valider avec Maj+Ctrl+Entrée
DVSansVides
Version triée
-Sélectionner C2:C8
=INDEX(champ;EQUIV(GRANDE.VALEUR(NB.SI(champ;">="&champ);LIGNE(INDIRECT("1:"&LIGNES(champ))));
NB.SI(champ;">="&champ);0))
-Valider avec Maj+ctrl+entrée
Avec une fonction personnalisée
FonctionSansVideTrié
Liste conditionnelle
DVCond
En D2:
=SI(LIGNES($1:1)<=NB.SI(cond;"o");
INDEX(champ;PETITE.VALEUR(SI(cond="o";LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1)));"")
Valider avec Maj+ctrl+entrée
Liste sans doublons
On veut la liste des produits sans doublons
-Sélectionner D2
=INDEX(produit;MIN(SI(produit<>"";SI(NB.SI(D$1:D1;produit)=0;LIGNE(INDIRECT("1:"&LIGNES(produit)));LIGNES(produit)))))
Valider avec maj+ctrl+entrée
DVSansDoublons
La dernière cellule du champ Produit doit être vide.
Si le champ ne contient pas de vide, le nom peut être défini avec produit =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A))
VBA:
DVSansDoublonsVBA
Le menu peut être crée directement sans colonne intermédiaire:
-Pour Excel 2000, la liste ne doit pas dépasser 200 caractères
-Pour Excel 2007, la liste ne doit pas dépasser 8000 caractères
DVSansDoublonsVBA
DVSansDoublonsVBATriée
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" Then
Set mondico = CreateObject("Scripting.Dictionary")
For Each c In
If Not mondico.exists(UCase(c.Value)) Then
mondico(UCase(c.Value)) = ""
temp = temp & UCase(c) & ","
End If
Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Liste sans doublons triée
La liste sans doublons triée en D2 est créée à chaque modification dans la colonne A.
ListeSansDoublonsTriée
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
[A1:A1000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=, Unique:=True
[D2:D1000].Sort key1:=
End If
End Sub
Avec une fonction personnalisée:
ListeSansDoublonsVBA
Autre exemple
On affiche la liste des affaires d'une société choisie dans un menu en A2.
Pour obtenir la liste des sociétés sans doublons, en D2:
=INDEX(Société;MIN(SI(Société<>"";SI(NB.SI($D$1:D1;Société)=0;LIGNE(INDIRECT("1:"&LIGNES(Société)));LIGNES(Société)))))
DVSansDoublons2
Ci dessous, la saisie se fait en colonne A avec des listes déroulantes
Ces listes sont alimentées avec la liste sans doublons (colonne C) des éléments déjà saisis.
-Sélectionner C2
=INDEX(Saisie;MIN(SI(Saisie<>"";SI(NB.SI(C$1:C1;Saisie)=0;LIGNE(INDIRECT("1:"&LIGNES(Saisie)));LIGNES(Saisie)))))
Valider avec maj+ctrl+entrée
Saisie avec mot de passe
Un mot de passe est demandé pour valider la modification.
DVMotPasse
DVMotPasseFormulaire
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([B2:B7], Target) Is Nothing And Target.Count = 1 Then
mp = InputBox("Mot de passe? ")
If mp <> "toto" Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Annulé!"
End If
End If
End Sub
Donnée/Validation avec Access
DVAccess
DvAccess2
ComboAccess2
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")..CopyFromRecordset rs
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End If
End Sub
Personnalisé
Saisir en majuscules
=EXACT(MAJUSCULE(B2);B2)
Saisir du texte
=ESTTEXTE(A2)
Saisir du numérique
=ESTNUM(A2)
Saisir un code postal
=ET(NBCAR(A2)=5;ESTNUM(A2))
Empêcher la saisie dans une cellule
=B2=""
Plage horaire
Les heures doivent être comprises entre 9-18h
=ET(B2>=--"9:0";B2<=--"18:0")
Une date doit être comprise dans 2 plages
=ET(B2>=--"01/01/2007";B2<=--"31/12/2007"))
La différence entre HeureFin et HeureDébut doit être inférieure à 9:0
-Sélectionner A2:B2
-Données/Validation
-Personnalisé
=$B$2-$A$2<=--"9:0"
La somme ne doit pas dépasser 100
-Sélectionner B2:B6
-Données/Validation/Personnalisé
=SOMME($B$2:$B$6)<=100
Doublons interdits dans un champ
On interdit la saisie de doublons dans le champ B2:B5:
-Sélectionner B2:B5
-Données/Validation/Personnalisé
=NB.SI(B$2:B$5;B2)=1
Doublons interdits dans un champ (2 critères)
Pour interdire les doublons Nom+Prénom dans un champ:
-Sélectionner A2:B11
-Données/Validation/Personnalisé
=SOMMEPROD(($A$2:$A$11=$A2)*($B$2:$B$11=$B2))<2
Vérification email
On vérifie qu'il y a bien @ et . Dans le email
=ET(NON(ESTERREUR(CHERCHE("@";C3)));NON(ESTERREUR(CHERCHE(".";C3))))
Pas d'espace dans la saisie
On ne peut pas saisir d'espace seul dans la cellule ni de double espace
Données/Validation/personnalisé
=SUPPRESPACE(B3)=B3
Vérification no sécu
Données/Validation/personnalisé
=97-(GAUCHE(A2;NBCAR(A2)-2)-97*ENT(GAUCHE(A2;NBCAR(A2)-2)/97))=CNUM(DROITE(A2;2))
Interdire la saisie sur un champ sans protéger la feuille
-Sélectionner le champ
-Données/validation/Perso
-Faux
Interdire la saisie dans un champ si B2 est égal à Non
-Sélectionner le champ B6:D10
-Données/validation/Personnalisé
=SI($B$2<>"non";VRAI)
Seul l'utilisateur 'xxxx' peut saisir dans le champ B4:D9
Dans un module
Function NomUser()
NomUser = Environ("username")
End Function
-Sélectionner le champ à protéger
-Données/Validation/Perso
=$A$1="Boisgontier"
Liste différence
On planifie des personnes pour différentes activités. Ne sont proposés dans les menus que les personnes non affectées.
DVDiff
DVDiffNum1_9
DVDiffNum0_9
DVDiffForm
En E2:
=SI(LIGNES($1:1)<=NBVAL(Tous)-NBVAL(Choisis);
INDEX(Tous;PETITE.VALEUR(SI((NB.SI(Choisis;Tous)=0);LIGNE(INDIRECT("1:"&LIGNES(Tous))));LIGNES($1:1)));"")
Autre exemple avec plusieurs mois
DVDiffMois
DVDiffSemaine
En I2:
=SI(LIGNES($1:1)<=NBVAL(Tous)-SOMMEPROD(NB.SI(Tous;B$2:B$8));
INDEX(Tous;PETITE.VALEUR(SI((NB.SI(B$2:B$8;Tous)=0);LIGNE(INDIRECT("1:"&LIGNES(Tous))));LIGNES($1:1)));"")
ListeDifférencesMultiples
Autre exemple
Chaque jour, on affecte des personnes à des activités. Une personne ne doit être affectée qu'une seule fois.
Dvdifference
ListeDifférence2
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
[L2:L100].ClearContents
For Each c In
If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) Then
.End(xlUp).Offset(1, 0) = c
End If
Next c
End If
End Sub
Coloriage des noms
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
On Error Resume Next
Target.Font.ColorIndex = .Find(Target, LookAt:=xlWhole).Font.ColorIndex
End If
End Sub
Sans liste intermédiaire (si la liste des noms est<200 caractères pour Excel<2007)
DvDifférence4
If Not Intersect(, Target) Is Nothing Then
temp = ""
For Each c In
If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) Then
temp = temp & c.Value & ","
End If
Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
Autre exemple DVDiff
Autre exemple Liste Différence Véhicules Prêt
Un véhicule peut être prêté successivement dans le temps à plusieurs Centres.
Si le véhicule n'a pas encore été restitué, il ne peut être prété à nouveau.
En G2: =SI(ET(E2="";B2<>"");B2;0)
En M2: =SI(LIGNES($1:1)<=NBVAL(vehicules)-NB.SI(prétés;"<>0");
INDEX(vehicules;PETITE.VALEUR(SI((NB.SI(prétés;vehicules)=0);
LIGNE(INDIRECT("1:"&LIGNES(vehicules))));LIGNES($1:1)));0)
Noms de champ
dates =$C$2:$C$100
prétés =Prêt!$G$2:$G$100
vehicules =Prêt!$I$2:$I$12
Autre exemple DVDiffPlanBureau
Pour chaque date,un bureau ne peut être affecté qu'une fois.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
temp = ""
For Each c In
If IsError(Application.Match(c, Range(Cells(3, Target.Column), Cells(20, Target.Column)), 0)) Then
temp = temp & c.Value & ","
End If
Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Planification de ressources avec grille d'absences
PlanifRessources
PlanifRessources2
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("planning"), Target) Is Nothing And Target.Count = 1 Then
[I2:J12].ClearContents
ColDate = Target.Column - .Column + 1
LigActiv = Target.Row - .Row + 1
For Each c In
LigNom = Application.Match(c, , 0)
a = Range("planning").Value
dispo = IsError(Application.Match(c, Application.Index(a, , ColDate), 0))
temAbs = Application.Index(, LigNom, ColDate)
If temAbs = "" And dispo Then
.End(xlUp).Offset(1) = c
If Application.CountA() > 0 Then _
.End(xlUp).Offset(, 1) = Application.CountIf(, c) / Application.CountA()
End If
Next c
End If
End Sub
Liste différence 3D
Des salles sont mises en commun pour plusieurs utilisateurs (Dupont,Martin,Charlie).
Une salle ne peut être réservée 2 fois pour la même date par 2 utilisateurs.
DVDiff3D
CalendrierSalles
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set champ = Range("B3:B30")
Onglets = Array("Dupont", "martin", "Charlie")
'---
p = Application.Match(Sh.Name, Onglets, 0)
If Not IsError(p) And Not Intersect(champ, Target) Is Nothing Then
temp = ""
ligne = Target.Row
col = Target.Column
For Each c In
témoin = False
For Each s In Onglets
If c = Sheets(s).Cells(ligne, col) Then témoin = True
Next s
If Not témoin Then temp = temp & c.Value & ","
Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
.Select
End Sub
Affichage d'un item ou de tous les items
Si l'opérateur choisit * dans la liste des villes , tous les départements sont affichés.
-Sélectionner D3:D7
=SI(B3="*";Départ;INDEX(Départ;EQUIV(B3;Villes;0)-1))
-Valider avec Maj+ctrl+entrée
MFC pour cacher les doublons si l'opérateur choisit une seule ville:
-Sélectionner D4:D7
-Format/MFC/La formule est
=D3=D4/Police en blanc
DVTous
Données/Validation classeur fermé
Solution1:Liaison
DVClasseurFerméLiaison
-Les données sont dans un classeur fermé DVSource.xls
-Dans l'onglet Liste du classeur où est situé le menu Données/Validation, créer une liste intermédiaire avec une liaison versDVSource.Xls.
-Sélectionner A2:A20
='C:\mesdoc\excelmacronouveau\1001exemples[DVSource.xls]Feuil1'!$A$2:$A$20
-Valider avec maj+ctrl+entrée
Si le champ dans DVSource.xls est nommé MaListe:
='C:\mesdoc\excelmacronouveau\1001exemples[DVSource.xls]MaListe
-Créer un nom de champ Liste
liste =DECALER(Liste!$A$2;;;NB.SI(Liste!$A$2:$A$20;"<>0")-1)
Solution2 : ADO
-Les données sont dans un classeur fermé DVSource.xls
-Elles sont copiées avec ADO en ordre alpha dans l'onglet Liste du classeur où est situé le menu Données/Validation
DV Classeur Fermé
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Microsoft ActiveX DataObject doit être coché
If Target.Address = "$B$2" Then
repertoire = ThisWorkbook.Path & "\"
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & repertoire & "\" & "DVSource.xls"
Set rs = cnn.Execute("SELECT noms FROM MaBD where noms<>''" ORDER BY noms)
Sheets("Liste").[A2:A1000].ClearContents
Sheets("Liste")..CopyFromRecordset rs
End If
End Sub
Solution3:Si la liste est < à 200 caractères
Il n'y a plus besoin d'une liste intermédiaire.
DVClasseurFerme2
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Microsoft ActiveX DataObject doit être coché
If Target.Address = "$B$2" Then
repertoire = ThisWorkbook.Path & "\"
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & repertoire & "\" & "DVSource.xls"
Set rs = cnn.Execute("SELECT noms FROM MaBD where noms<>'' ORDER BY noms")
Do While Not rs.EOF
temp = temp & rs("noms") & ","
rs.MoveNext
Loop
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
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 - Cells(ActiveWindow.ScrollRow, 1).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
Choix d'une image avec données/Validation
Images internes au classeur
Choix d'une image interne avec Decaler()
-Placer une photo dans la feuille en A4
-Créer les noms de champ avec Insertion/Nom/Définir
-Noms =Photos!$A$2:$A$9
-Adr: =DECALER(Photos!$B$2;EQUIV(Feuil1!$A$2;Noms;0)-1;0)
-Cliquer sur l'image en A4
-Dans la barre de formule:=Adr
AffichePhoto
AffichePhoto2
Image ConditionnelleInterne
Image ConditionnelleInterne 2
Autre solution
-Noms : =Photos!$A$2:$A$9
-Photos: =Photos!$B$2:$B$9
-Adr: =INDEX(photos;EQUIV(Feuil1!$A$2;Noms;0))
AffichePhotoB
Choix d'une seule image avec VBA
Les noms des images correspondent aux noms des personnes.
DVChoixUneImageInterne
DVChoixUneImageInterne2
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
On Error Resume Next
ActiveSheet.Shapes("monimage").Delete
On Error GoTo 0
If Target <> "" Then
Sheets("Images").Shapes(Target).Copy
Target.Offset(0, 2).Select
ActiveSheet.Paste
Selection.Name = "monImage"
Selection.ShapeRange.Left = ActiveCell.Left
Selection.ShapeRange.Top = ActiveCell.Top
Target.Select
End If
End If
End Sub
choix de plusieurs images
Les images de l'onglet Images sont nommées En cours,Attente,Fini.
DVImagesInternes
DVLogo
DVMétéo
DVChoixGroupeImages
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 And Target.Count = 1 Then
'-- suppression
For Each s In ActiveSheet.Shapes
If s.Type = 13 Then
If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then
s.Delete
End If
End If
Next s
'--
If Target <> "" Then
Sheets("Images").Shapes(Target).Copy
Target.Offset(0, 1).Select
ActiveSheet.Paste
Selection.ShapeRange.Left = ActiveCell.Left + 7
Selection.ShapeRange.Top = ActiveCell.Top + 5
Target.Select
End If
End If
End Sub
Sur cet exemple, après avoir choisi une image dans une cellule, l'opérateur peut cliquer sur l'image déjà choisie pour modifier son choix. Le menu déroulant est ouvert automatiquement.
DVMétéo
DVMétéo2
FormMétéo
ListBoxPhotoInterneCommentaire
Private Sub Worksheet_Change(ByVal Target As Range)
Set images = Sheets("logos")
If Target.Column = 2 And Target.Count = 1 Then
'-- suppression
For Each s In ActiveSheet.Shapes
If s.Type = 13 Then
If s.TopLeftCell.Address = Target.Address Then s.Delete
End If
Next s
If Target <> "" Then
On Error Resume Next
images.Shapes(Target).Copy
If Err = 0 Then
ActiveSheet.Paste
Selection.OnAction = "ClicImage"
Selection.Name = "Image" & ActiveCell.Row
largeurImage = images.Shapes(Target).Width
HauteurImage = images.Shapes(Target).Height + 6
Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
Selection.ShapeRange.Top = ActiveCell.Top + 5
Rows(Target.Row).RowHeight = HauteurImage + 10
Target.Select
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 2 And Target.Count = 1 Then
If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
SendKeys "%{down}"
End If
End If
End Sub
Sub ClicImage()
Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Select
SendKeys "%{down}"
End Sub
Les images de l'onglet Images n'ont pas besoin d'être nommées
Les images de l'onglet Images n'ont pas besoin d'être nommées.
ChoixImage
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Count = 1 Then
'-- suppression
For Each s In ActiveSheet.Shapes
If s.Type = 6 Or s.Type = 9 Then
If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then
s.Delete
End If
End If
Next s
'--
If Target <> "" Then
lig = .Find(Target, LookAt:=xlWhole).Row
col = .Column + 1
For Each s In Sheets("Images").Shapes
If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
Next s
Target.Offset(0, 1).Select
ActiveSheet.Paste
Selection.ShapeRange.Left = ActiveCell.Left + 7
Selection.ShapeRange.Top = ActiveCell.Top + 5
Target.Select
End If
End If
End Sub
Récupération d'un champ ou d'une image interne dans un commentaire
RecupChampComment
RecupImageInterneComment
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
répertoire = ThisWorkbook.Path
lig = .Find(Target, LookAt:=xlWhole).Row
col = .Column + 1
Cells(lig, col).CopyPicture
x = Cells(lig, col).Width
y = Cells(lig, col).Height
ActiveSheet.Paste Destination:=Range("A1") 'crée un shape
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Copy
With ActiveSheet
.ChartObjects.Add(0, 0, s.Width, s.Height * 1.15).Chart.Paste
.ChartObjects(1).Border.LineStyle = 0
.ChartObjects(1).Chart.Export Filename:=répertoire & "\monimage.gif", FilterName:="gif"
.Shapes(ActiveSheet.Shapes.Count).Delete
.Shapes(ActiveSheet.Shapes.Count).Delete
End With
Target.Comment.Delete
Target.AddComment
Target.Comment.Shape.Fill.UserPicture répertoire & "\monimage.gif"
Target.Comment.Shape.Height = y
Target.Comment.Shape.Width = x
End If
End Sub
Images externes au classeur
Choix d'une seule image externe
Les noms des images correspondent aux noms des personnes.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
On Error Resume Next
ActiveSheet.Shapes("MonImage").Delete
rep = ThisWorkbook.Path
nomimage = rep & "\" & Target & ".jpg"
Target.Offset(0, 2).Select
ActiveSheet.Pictures.Insert(nomimage).Select
If Err > 0 Then MsgBox "inconnu"
On Error GoTo 0
Selection.Name = "MonImage"
Target.Select
End If
End Sub
Choix de plusieurs images externes
DVImagesExternes
Private Sub Worksheet_Change(ByVal Target As Range)
'-- suppression de l'image actuelle
If Target.Column = 1 And Target.Count = 1 Then
For Each s In ActiveSheet.Shapes
If s.Type = 13 Then
If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then s.Delete
End If
Next s
RépertoirePhotos = ThisWorkbook.Path & "\" ' adapter
On Error Resume Next
Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & Target & ".jpg")
If Err > 0 Then
MsgBox "inconnu"
Else
img.Left = Target.Offset(, 1).Left + 15
img.Top = Target.Offset(, 1).Top
End If
End If
End Sub
Autre exemple
DVImageExterne
Choix d'une image externe dans un combobox
L'image du produit choisi dans le combobox apparaît au survol.
Double cliquer en colonne A pour afficher le formulaire.
FormImageComboBox
Dim répertoire
Private Sub UserForm_Initialize()
répertoire = ThisWorkbook.Path
With Sheets("bd")
Me.ComboBox1.List = .Range("A2:A" & .Range("A65000").End(xlUp).Row).Value
End With
End Sub
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ligne = Int(Y / (ComboBox1.Font.Size * 1.18))
If ligne < Me.ComboBox1.ListCount Then
photo = ComboBox1.List(ligne + Application.Max(Me.ComboBox1.TopIndex, 0), 0) & ".jpg"
If Dir(répertoire & "\" & photo) <> "" Then
Me.Image1.Picture = LoadPicture(répertoire & "\" & photo)
Else
Me.Image1.Picture = LoadPicture
End If
End If
End Sub
Private Sub ComboBox1_Change()
ActiveCell = Me.ComboBox1
ActiveCell.Offset(, 1).Select
Set monimage = ActiveSheet.Pictures.Insert(repertoire & Me.ComboBox1 & ".jpg")
monimage.Left = ActiveCell.Left + 2
monimage.Top = ActiveCell.Top + 2
Unload Me
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 Then
UserForm3.Show
Cancel = True
End If
End Sub
Liste avec hyper-liens (Mail et lien)
ChoixMailLien
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:=Target.Value, TextToDisplay:=Target.Value
End If
End Sub
Choix d'un mail avec Lien_hypertexte
=LIEN_HYPERTEXTE("mailto:"&RECHERCHEV(A2;Noms;2;FAUX);RECHERCHEV(A2;Noms;2;FAUX))
Choix d'un mail avec FollowHyperLink
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
temp = Application.Index(, , 1).Find(Target, LookAt:=xlWhole).Offset(, 1)
ActiveWorkbook.FollowHyperlink Address:="mailto:" & temp
End If
End Sub
Choix d'un lien
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
ActiveWorkbook.FollowHyperlink Address:=Target, NewWindow:=True
End If
End Sub
Choix d'un lien vers une feuille
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
temp = .Find(what:=Target).Hyperlinks(1).SubAddress
a = Split(temp, "!")
Application.Goto Reference:=Sheets(a(0)).Range(a(1))
End If
End Sub
DVLien
Positionnement sur une cellule
On veut positionner le curseur sur une ville.
PositionCellule
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
[B10:B1000].Find(Target.Value, LookIn:=xlValues).Select
End If
End Sub
Version sans liste
Pour Excel <2007, la liste ne doit pas dépasser 200 caractères.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" Then
temp = ""
ligne = 10
Do While Cells(ligne, 2) <> ""
temp = temp & Cells(ligne, 2) & ","
ligne = ligne + 5
Loop
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
[B10:B1000].Find(Target.Value, LookIn:=xlValues).Select
End If
End Sub
Ajout de plusieurs listes
Listes contigües
DVAjoutListes
Listes non contigües
DVAjoutListes
Noms de champ
champ =ajoutListes!$A$2:$E$9
Liste =DECALER(ajoutListes!$G$2;;;NB.SI(ajoutListes!$G$2:$G$19;"><"&""))
En G2:
=SI(LIGNES($1:1)<=NBVAL(champ);INDEX(champ;
MOD(PETITE.VALEUR(SI(champ<>"";COLONNE(champ)*10^5+LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1));10^5);
ENT(PETITE.VALEUR(SI(champ<>"";COLONNE(champ)*10^5+LIGNE(INDIRECT("1:"&LIGNES(champ))));LIGNES($1:1))/10^5)-COLONNE(champ)+1);""))
Valider avec Maj+ctrl+entrée
Pour obtenir une liste unique triée
-Sélectionner H2:H13
=FusionTriMZ((B2:B10;D2:D5;F2:F8))
-valider avec maj+ctrl+entrée
Pour le menu: =DECALER($H$2;;;NB.SI($H$2:$H$13;"<>0"))
DVMZtrié
Dans un module:
Function FusionTriMZ(nom)
Set mondico = CreateObject("Scripting.Dictionary")
For i = 1 To nom.Areas.Count
For j = 1 To nom.Areas(i).Count
c = nom.Areas(i)(j)
If c <> "" And c <> 0 Then
If c <> "" And Not mondico.Exists(c) Then mondico.Add c, c
End If
Next j
Next i
Dim b()
ReDim b(1 To Application.Caller.Rows.Count)
i = 1
For Each c In mondico.items
b(i) = c
i = i + 1
Next
Call Tri(b, 1, mondico.Count)
FusionTriMZ = Application.Transpose(b)
End Function
Sub Tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
tmp = a(g): a(g) = a(d): a(d) = tmp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub
Liaison données-validation/Liste
Si on modifie un item de la liste, les choix déjà faits dans les menus déroulants sont modifiés.
DVLiaison
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
Application.EnableEvents = False
valSaisie = Target.Value
Application.Undo
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
If c.Value = Target Then c.Value = valSaisie
Next
Target = valSaisie
Application.EnableEvents = True
End If
End Sub
Modification d'un item dans les menu déroulants
DVModifItem
Sub ModifieItemListeValidation()
ancien = "kk"
nouveau = "pp"
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
If Left(c.Validation.Formula1, 1) <> "=" Then
temp = c.Validation.Formula1
temp = Replace(temp, ancien, nouveau)
temp = Replace(temp, ";", ",")
c.Validation.Delete
c.Validation.Add xlValidateList, Formula1:=temp
End If
Next c
End Sub
En cas d'erreur de saisie, la saisie est annulée sans message d'erreur.
Décocher Quand les données non valides sont frappées.
DVMessageErreur
Cas1: On connait le nom de la liste (MaListe)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" And Target <> "" Then
If IsError(Application.Match(Target, , 0)) Then
Application.Undo
End If
End If
End Sub
Cas2: Il y a plusieurs menus avec plusieurs listes
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("A2,A5"), Target) Is Nothing And Target <> "" Then
Application.EnableEvents = False
If Left(Target.Validation.Formula1, 1) = "=" Then ' Liste dans le tableur
NomListe = Mid(Target.Validation.Formula1, 2)
If IsError(Application.Match(Target.Value, Range(NomListe), 0)) Then
'MsgBox "Erreur!"
Application.Undo 'Target = Empty
End If
Else
temp = Target.Validation.Formula1 ' Liste dans le menu
p = InStr(temp, Target.Value)
If p = 0 Then
Application.Undo 'Target = Empty
End If
End If
Application.EnableEvents = True
End If
End Sub
Positionne chaque menu sur le premier élément de chaque liste
On veut positionner les menus sur le premier élément de chaque liste.
DVPosPremier
Sub raz()
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
If Left(c.Validation.Formula1, 1) = "=" Then
NomList = Mid(c.Validation.Formula1, 2)
c.Value = Sheets("listes").Range(NomList)(1)
Else
temp = c.Validation.Formula1
a = Split(temp, ";")
c.Value = a(0)
End If
Next c
End Sub
Saisie des initiales
L'opérateur saisit les initiales. Le nom et le prénom sont affichés. DVColoriage
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
Application.EnableEvents = False
On Error Resume Next
.Find(Target, LookAt:=xlWhole).Offset(0, 1).Copy Target
Application.EnableEvents = True
End If
End Sub
Choix d'une feuille du classeur
-Créer les noms de champ
NomsFeuilles =STXT(LIRE.CLASSEUR(1);TROUVE("]";LIRE.CLASSEUR(1))+1;99)&INDIRECT("iv65000")
NbFeuilles =LIRE.CLASSEUR(4)
Liste =DECALER(Recap!$A$2;;;NB.SI(Recap!$A$2:$A$9;"><"&""))
ChoixFeuille
En A2: =SI(LIGNES($1:1)<=NbFeuilles;INDEX(NomsFeuilles;LIGNES($1:1));"")
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$2" Then Sheets(Target.Value).Select
End Sub
Consolidation 3D de valeurs numériques
On consolide des listes des feuilles Div,Div2,Div3.
En A2: =PETITE.VALEUR(Div1:Div3!$A$1:$A$10;LIGNES($1:1))
DV3D
Consolidation 3D de valeurs alphabétiques
On veut la liste des immatriculations de la colonne C des feuilles Janv2010,Fev2010,Mars2010,...
-Sélectionner K2:K34
=Liste3D("C2:C100";2;NbOnglet)
Valider Maj+ctrl+entrée
Liste=DECALER($K$2;;;NB.SI(Interro!$K$2:$K$34;"<>#N/A"))
Liste3D
Function Liste3D(champ As String, fdeb, ffin)
Application.Volatile
Set mondico = CreateObject("Scripting.Dictionary")
For s = fdeb To ffin
For Each c In Sheets(s).Range(champ)
If c.Value <> "" Then mondico(c.Value) = c.Value
Next c
Next s
b = mondico.items
Call tri(b, LBound(b), UBound(b))
Liste3D = Application.Transpose(b)
End Function
Sub tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
Données/Validation avec champ multi-zones
-Le champ multi-zones Nom2 est défini avec =$A$2:$A$7;$C$2:$C$5;$E$2:$E$7
-Pour créer la liste
.Sélectionner G2:G14
.=listetriée(Nom2)
.Valider avec Maj+ctrl+entrée
-Le menu se crée avec Données/Validation/Liste =DECALER($G$2;;;NB.SI($G$2:$G$14;"<>0"))
DVMultiZones
Function FusionTriMZ(nom)
Set mondico = CreateObject("Scripting.Dictionary")
For i = 1 To nom.Areas.Count
For j = 1 To nom.Areas(i).Count
c = nom.Areas(i)(j)
If c <> "" And c <> 0 Then
If c <> "" And Not mondico.Exists(c) Then mondico.Add c, c
End If
Next j
Next i
Dim b()
ReDim b(1 To Application.Caller.Rows.Count)
i = 1
For Each c In mondico.items
b(i) = c
i = i + 1
Next
Call Tri(b, 1, mondico.Count)
FusionTriMZ = Application.Transpose(b)
End Function
Sub Tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
tmp = a(g): a(g) = a(d): a(d) = tmp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub
Maj des choix déjà effectués
Si on modifie une valeur de la liste de choix, les choix déjà effectués dans la feuille choix sont modifiés
DVMaj
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
For i = 1 To .Count
If Sheets("choix").Range("listeChoix")(i) = [mémo1] Then
Sheets("choix").Range("listeChoix")(i) = Target.Value
End If
Next i
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
ActiveWorkbook.Names.Add Name:="mémo1", RefersToR1C1:="=" & Chr(34) & Target.Formula & Chr(34)
End If
End Sub
Planification de salles
Une salle ne peut être affectée 2 fois le même jour. Dans le menu déroulant des salles n'apparaissent que les salles disponibles.
PlanifSalles
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect([C2:C200], Target) Is Nothing And Target.Count = 1 Then
début = Cells(Target.Row, 1)
fin = Cells(Target.Row, 2)
If début > 0 And fin > 0 Then
Set mondico = CreateObject("Scripting.Dictionary")
For ligne = 2 To 100
If (début >= Cells(ligne, 1) And début <= Cells(ligne, 2)) Or _
(fin >= Cells(ligne, 1) And fin <= Cells(ligne, 2)) Or _
(début <= Cells(ligne, 1) And fin >= Cells(ligne, 2)) Then
temp = Cells(ligne, 3)
mondico(temp) = temp
End If
[I2:I100].ClearContents
For Each c In
If Not mondico.Exists(c.Value) Then
.End(xlUp).Offset(1) = c
End If
Next c
Else
[I2:I100].ClearContents
End If
End If
End Sub
Planification de véhicules
Unvéhicule ne peut être affecté 2 fois dans la même période. Dans le menu déroulant des véhicules n'apparaissent que les véhicules disponibles.
PlanifVéhicules
PlanifVéhicules3
Planification de ressources
Chaque jour, on affecte des personnes à des activités en fonction d'une grille de compétences et des absences.
PlanificationRessources
Grille de compétences et absences
Noms de champ
absence =Grille!$B$12:$J$42
Activité =Grille!$A$2:$A$7
Dates =PlanningAct!$A$4:$A$34
Grille =Grille!$B$2:$J$7
ListeNoms =Grille!$B$1:$J$1
ListePersoDispo =DECALER(PlanningAct!$J$2;;;NBVAL(PlanningAct!$J:$J)-1)
Planning =PlanningAct!$B$4:$G$34
Planning2 =PlanningNom!$B$5:$AF$13
Affectation manuelle
Un menu déroulant donne la liste des personnes disponibles pour une activité et une date.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(, Target) Is Nothing Then
[J2:K100].ClearContents
For Each c In
colNom = Application.Match(c, , 0)
ligAct = Target.Column - 1
dispo = Application.Index(, ligAct, colNom)
ligDate = Target.Row - 3
temAbs = Application.Index(, ligDate, colNom)
If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) _
And dispo And Not temAbs Then
.End(xlUp).Offset(1, 0) = c
tauxOccup = Application.CountIf(, c)
If Application.CountA() > 0 Then
.End(xlUp).Offset(0, 1) = tauxOccup / Application.CountA()
End If
End If
Next c
End If
End Sub
Affectation automatique
Affecte automatiquement en maintenant une égalité des taux d'affectation.
Sub affectationPlanningAutomatique()
Dim noms(), taux()
Application.ScreenUpdating = False
.ClearContents
For lig = 1 To .Rows.Count
d = Cells(lig + .Row - 1, 1)
If Weekday(d, 2) < 6 Then
For col = 1 To .Columns.Count
nbnoms = 0
For Each c In
colNom = Application.Match(c, , 0)
dispo = Application.Index(, col, colNom)
temAbs = Application.Index(, lig, colNom)
b = Application.Transpose(.Cells(lig, 1).Resize(, 6))
If IsError(Application.Match(c, b, 0)) _
And dispo And Not temAbs Then
nbnoms = nbnoms + 1
ReDim Preserve noms(1 To nbnoms)
ReDim Preserve taux(1 To nbnoms)
noms(nbnoms) = c
tauxOccup = Application.CountIf(, c)
If Application.CountA() > 0 Then
taux(nbnoms) = tauxOccup / Application.CountA()
End If
End If
Next c
If nbnoms > 0 Then
TauxMin = Application.Min(taux)
p = Application.Match(TauxMin, taux, 0)
If IsError(p) Then p = 1
Range("planning").Cells(lig, col) = noms(p)
End If
Next col
End If
Next lig
End Sub
Planning par nom obtenu par formule
Planification avec grille de compétences et formulaire
Lorsque l'opérateur sélectionne un stage, seules les personnes compétentes pour ce stage apparaissent dans le menu déroulant.
DVCompétences
Recherche par mot clé
Dv Recherche MotsClés Séparés Par Virgule
Form Recherche Mots Clés Séparés Par Virgule
Dv Recherche Mots Clés Séparés Par Espace
Form Recherche Mots Clés Séparés Par Espace
|