Accueil

Nombres entiers Saisie nombre entre 2 valeurs Listes Liste déroulante Liste sur un autre onglet /classeur ouvert Liste dans un classeur fermé Liste dynamique Largeur Menu automatique en bas d'une colonne de saisie Ouverture automatique d'une liste Ouverture automatique d'une liste au survol Zoom Choix de la langue Liste conditionnelle Liste conditionnelle colonne Récupération de la couleur Récupération couleur sélection multiple Récupération du format Récupération de la mise en forme Récupération commentaire Récupération du code Liste en couleur Ajout liste dynamique Simulation flèche de données/validation Choix dans un formulaire Choix dans un formulaire(liste>8) Simulation de Données/Validation avec ComboBox Coloriage de la ligne Historique en commentaire Récupération des 3 premiers caractères Saisie une seule fois Choix successifs Liste 2 colonnes Liste sans vides Liste sans doublons Liste sans doublons VBA Liste sans doublons triée Liste intuitive (saisie semi-automatique TextBox & ListBox intuitif) Simulation de données/validation avec ComboBox AutoCompletion avec combobox Choix d'un nom avec doublons Choix avec plusieurs colonnes dans un formulaire Menu déroulant avec fichier fermé(ADO) Devis Ajout liste Affiche le nombre d'étoiles choisi Liste automatique avec les items de la colonne Ajout de plusieurs listes Choix d'une image Choix d'un hyperlien Choix d'une feuille du classeur Consolidation 3D Champ multi-zones Liaison Positionne sur premier de la liste Listes déroulantes liées Données/Validation avec Bulle ComboBox 2 colonnes Listes conditionnelles Liste en fonction d'une valeur Liste conditionnelle Liste disponible les jours ouvrés Validation Planning Particularités de 2019

Personnalisé Majuscules Saisir un code postal Plagehoraire PlageDate Différence horaire Somme inférieure à 100 Doublons interdits Doublons interdits (2 critères) Vérification email No sécurité sociale Interdire la saisie dans un champ

Liste Différence Choix de plusieurs activités ListesCascade -DV avec classeur fermé -DV avec Access & ADO -Avec plusieurs listes -Planning avec absences -Planning avec grille compétences -Planning salles -Planning véhicules -Planning ressources -Saisie des initiales -Recherche par mot clé

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
=[X.XLS]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

Avec ADO

DVADO
Article.xls

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

Menu automatique en bas d'une colonne de saisie

En plaçant le curseur en bas d'une colonne de saisie et avec un clic-droit/Liste de choix, on obtient la liste de tous les items de la colonne.
Avec ce programme, lorsque l'opérateur clique en bas de la colonne de saisie , la liste des items présents dans la colonne est affichée automatiquement.

DVSimul

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Not Intersect(Range("a2:a1000"), Target) Is Nothing And Target.Count = 1 Then
     SendKeys "%{down}"
   End If
End Sub

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)
  [b2].Select
  SendKeys "%{down}"
End Sub

Zoom au clic sur une liste déroulante

Des listes déroulantes sont situées en A2:A10. Lorsque l'opérateur clique sur une de ces listes, le zoom sur la feuille est activé à 80%. Il est remis à 50% après le choix effectué.

Zoom Selection

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Range("a2:a10"), Target) Is Nothing And Target.Count = 1 Then
     ActiveWindow.Zoom = 80
  Else
    ActiveWindow.Zoom = 50
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  ActiveWindow.Zoom = 50
End Sub

Autre version avec mémorisation du zoom dans un nom.

Zoom Selection 2
Zoom Selection 3

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Range("a2:a10"), Target) Is Nothing And Target.Count = 1 Then
  ActiveWindow.Zoom = 80
Else
  ActiveWindow.Zoom = [ZoomStandard]
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  ActiveWindow.Zoom = [ZoomStandard]
End Sub

Pour créer le nom ZoomStandard:

-Régler le Zoom standard (50% par exemple)
-Cliquer sur le bouton: Crée Zoom Standard Le Zoom standard est sauvegardé dans le nom ZoomStandard

Private Sub B_CréeZoomStandard_Click()
  ActiveWorkbook.Names.Add Name:="ZoomStandard", RefersTo:=ActiveWindow.Zoom
End Sub

On peut également créer directement le nom ZoomStandard avec la commande Formules/Gestionnaire de noms/Définir un nom

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)

DV Liste1 ou Liste2
DV Liste Rien
ListeCond1
ListeCond2

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

Choix de la langue

-On peut choisir la langue
-Si on modifie un item de la liste, les choix déjà faits dans les menus déroulants sont modifiés

DV langue liaison

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

Liste conditionnelle en fonction d'une colonne

DVCond
DVCondCombo

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 conditionnelle en fonction du jour

DVJour

En J2:
=SI(LIGNES($1:1)<=NBVAL(INDEX(Cond;;EQUIV($H$2;jours;0)));
INDEX(Noms;PETITE.VALEUR(SI((jours=$H$2)*(Cond="x");LIGNE(INDIRECT("1:"&LIGNES(Noms))));LIGNES($1:1)));"")
Valider avec Maj+ctrl+entrée

Récupération de la couleur d'une liste

La couleur est modifiée après le choix dans la liste.

D vListe Recup Couleur
DvJourDemiJour
Dv Coloriage Shape

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Interior.ColorIndex = [couleurs].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([planning], Target) Is Nothing Then
    Application.EnableEvents = False
    Selection.Value = Target
    Application.EnableEvents = True
    On Error Resume Next
    Selection.Interior.ColorIndex = [couleurs].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([planning], Target) Is Nothing Then
     Application.EnableEvents = False
     On Error Resume Next
    [Couleurs].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
    [Liste].Find(Target, LookAt:=xlWhole).Copy Target
    Target.Validation.Add xlValidateList, Formula1:="=Liste"
    Application.EnableEvents = True
  End If
End Sub

Autres exemples avec police Wingdings

Wingding
Wingdings Boutons
WingDingsComboBox

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect([B2:B5], Target) Is Nothing Then
   Application.EnableEvents = False
   On Error Resume Next
   [Liste].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

Recup Commentaire
Recup Commentaire3

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$D$2" Then
    Application.EnableEvents = False
    [MaListe].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 = [fournisseur].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 [A1].Select
  End If
End Sub

On récupère la colonne de droite

DV Colonne Droite
DV Colonne Gauche ComboBox

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 = [liste].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 = [couleurs].Value
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
   If Me.ComboBox1.ListIndex <> 0 Then
      On Error Resume Next
     [couleurs].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

Simulation de données/validation avec ComboBox

Ici, on simule Données/validation avec un ComboBox. La liste affichée peut être supérieure à 8.

DVComboBox
DVListBox
DVComboBox 2 col NomPrénom
DVComboBox 2 col

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A2:A16], Target) Is Nothing And Target.Count = 1 Then
    Me.ComboBox1.List = Range("Liste").Value
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True  
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Change()
  ActiveCell.Value = Me.ComboBox1
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = 13 Then ActiveCell.Offset(1).Select
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.[H65000].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 = [Noms].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 = [etat].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([planning], Target) Is Nothing Then
   If NomUtil() = "Boisgontier" Then
     On Error Resume Next
     Target.Interior.ColorIndex = Sheets("couleurs").[couleursV].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
   Else
     On Error Resume Next
    Target.Interior.ColorIndex = Sheets("couleurs").[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
DV 2 colonnes2

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([Maliste], , 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([MaListe], , 1), 0)
      If IsError(p) Then
         Application.EnableEvents = False
         Application.Undo
         Application.EnableEvents = True
      Else
         Application.EnableEvents = False
         Target.Value = Target.Value & " " & Application.Index([MaListe], 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([MaListe], , 1), 0)
   If IsError(p) Then
     Application.EnableEvents = False
     Application.Undo
     Application.EnableEvents = True
   Else
     Application.EnableEvents = False
    Target.Offset(, 1).Value = Application.Index([MaListe], 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 = [libelle].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([Liste], , 1), 0)
    If IsError(p) Then
      Application.EnableEvents = False
      Application.Undo
      Application.EnableEvents = True
    Else
      Application.EnableEvents = False
      Target.Value = Application.Index([Liste], 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
Devis Multicolonnes

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 = [BD].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
Devis Multicolonnes

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 = [BdArt].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

Affiche le nombre d'étoiles choisi

DV Etoiles

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, [Liste], 0)) Then
        If MsgBox("On ajoute?", vbYesNo) = vbYes Then
          [Liste].End(xlDown).Offset(1, 0) = Target.Value
          Sheets("Liste").[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" & [a65000].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

DV Sans Vides
DV Sans Vides VBA

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:

DV Sans Doublons VBA

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

DV Sans Doublons VBA
DV Sans Doublons VBATriée
DV Communs VBA

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In [ticket]: d(c.Value) = "": Next c
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
  End If
End Sub

Avec Power Query

DV sans Doublons Power Query

-Construire produits_2 avec Power Query
=INDIRECT("produits_2")

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:=[D1], Unique:=True
    [D2:D1000].Sort key1:=[D2]
  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

Liste déroulante intuitive des noms commençant par les premières lettres frappées (comme sur Google)

La saisie dans le combobox se fait de façon intuitive. La liste des noms apparaît au fur et et à mesure de la frappe des premières lettres comme pour la recherche sur Google.

Pour obtenir la liste complète des noms faire un double-clic.

Recherche iIntuitive premières Lettres
Recherche iIntuitive Google
Recherche iIntuitive premières Lettres Nom prénom
Recherche Intuitive lettres contenues
Recherche Intuitive lettres contenues2

Pour créer le combobox:

-Onglet développeur
-insérer Contrôles ActiveX

La propriété MacthEntry du combobox doit être positionée sur None

Private Sub ComboBox1_Change()
  If Me.ComboBox1 <> "" Then
    a = Application.Transpose(Sheets("BD").[Liste])
    Me.ComboBox1.List = Filter(a, Me.ComboBox1.Text, True, vbTextCompare)
    Me.ComboBox1.DropDown
    [e2] = Me.ComboBox1
  End If
End Sub

Textbox+ Listbox intuitif

Au fur et à mesure de la frappe des caractères dan un TextBox, les noms sont affichés dans un ListBox.
Au départ, le Listbox est masqué. Il est également masqué lorsque le choix est fait.

TextBox Intuitif

Dim témoin
Private Sub TextBox1_Change()
  If Not témoin Then
    a = [liste].Value
    Set d1 = CreateObject("Scripting.Dictionary")
    Me.ListBox1.Clear
    If Me.TextBox1 = "" Then
       Me.ListBox1.Visible = False
       [A1] = ""
    Else
      tmp = UCase(Me.TextBox1) & "*"
      For Each c In a
        If UCase(c) Like tmp Then d1(c) = ""
      Next c
      Me.ListBox1.List = d1.keys
      Me.ListBox1.Height = d1.Count * 11
      Me.ListBox1.Visible = True
    End If
  Else
   témoin = False
  End If
End Sub

Private Sub ListBox1_Click()
  [A1] = Me.ListBox1
  Me.ListBox1.Visible = False
  témoin = True
  Me.TextBox1 = ""
End Sub

Simulation de Données/Validation avec saisie intuitive caractère par caractère

Données/validation permet la saisie intuitive (semi-automatique) :
-En frappant les premières lettres et en cliquant sur la flèche, on obtient la liste des items commençant par les lettres frappées. Mais elle ne permet pas d'obtenir la liste des items au fur et à mesure de la frappe des caractères comme sur Google.
-Ci dessous, lors du clic dans une cellule, un combobox apparaît, permettant une saisie intuitive caractère par caractère comme sur Google. La liste des noms de pays commençant par les lettres frappées apparaît automatiquement au fur et à mesure de la frappe des caractères.
Si on ne veut pas que la liste déroulante affiche tous les noms au clic dans la cellule, supprimer Me.ComboBox1.DropDown.

Liste déroulante Intuitive Tableur Multiple
Liste déroulante Intuitive Tableur Multiple Nom prénom
Liste déroulante Intuitive Tableur Multiple Accent
Liste déroulante Intuitive Tableur Multiple lettres contenues
Liste déroulante Intuitive Planification
Liste déroulante Intuitive Villes
Liste conditionnelle intuitive produit
Liste conditionnelle intuitive Départ Ville
Liste déroulante Intuitive Tableur Multiple 2 colonnes
Fiche technique Intuitive 2 colonnes
Recherche Intuitive 2 colonnes
Recherche Intuitive Doublons
Recherche Intuitive Items colonne

Dim a()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A2:A16], Target) Is Nothing And Target.Count = 1 Then
    a = Sheets("bd").Range("liste").Value
    Me.ComboBox1.List = Sheets("bd").Range("liste").Value
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown ' ouverture automatique au clic dans la cellule
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Change()
  If Me.ComboBox1 <> "" Then
    Set d1 = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In a
      If UCase(c) Like tmp Then d1(c) = ""
    Next c
    Me.ComboBox1.List = d1.keys
    Me.ComboBox1.DropDown
  End If
  ActiveCell.Value = Me.ComboBox1
End Sub

Liste déroulante intuitive avec formulaire (saisie intuitive semi automatique comme Google)

La saisie dans le combobox se fait de façon intuitive. La liste des noms apparaît au fur et et à mesure de la frappe des premières lettres comme pour la recherche sur Google.

La propriété MacthEntry doit être positionnée sur None.

Pour obtenir la liste des noms contenant les lettres frappées, remplacer   tmp = UCase(Me.ComboBox1) & "*" par tmp = "*" & UCase(Me.ComboBox1) & "*"

Liste Intuitive Form Début
Liste Intuitive Form Contenu
Liste Intuitive Form Contenu Filter
Liste Intuitive Form Villes
Liste Intuitive Form 2 colonnes
Liste Intuitive Form Ville Code postal
Liste Intuitive Dates

AutoCompletion avec combobox

En frappant la ou les première(s) lettre(s), on voit apparaître le premier mot commençant par les lettres frappées.

AutoCompletion

La propriété MatchEntry du Combobox est positionnée sur Complete.

Dim a()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([A2:A16], Target) Is Nothing And Target.Count = 1 Then
    a = Sheets("bd").Range("liste").Value
    Me.ComboBox1.List = a
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
  Else
    Me.ComboBox1.Visible = False
   End If
End Sub

Private Sub ComboBox1_Change()
  ActiveCell.Value = Me.ComboBox1
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = 13 Then ActiveCell.Offset(1).Select
End Sub

Recherche intuitive de plusieurs mots séparés par le caractère espace

On recherche par exemple un intitulé d'article : Table bois peint blanc plateau zinc 1 tiroir
L'intitulé est retouvé en frappant : bois blanc tiroir

Liste intuitive plusieurs mots
Liste intuitive plusieurs mots Formulaire
Liste intuitive plusieurs mots PC MAC
Liste Intuitive Plusieurs mots désordre formulaire
Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox

Sur cet exemple, on recherche plusieurs mots dans le désordre et dans toutes les colonnes de la BD

Liste Intuitive Plusieurs mots désordre formulaire TextBox ListBox Multi-colonnes

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").[A2].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
DVDiffMultiOnglets
DVDiffMultiOngletsVBA
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)));"")

Avec un comboBox

DV Jour Liste Diff VBA

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set zsaisie = Range("B2:C16")
  If Not Intersect(zsaisie, Target) Is Nothing And Target.Count = 1 Then
    jour = Cells(Target.Row, "a")
    Set d = CreateObject("scripting.dictionary")     ' choisis
    For i = zsaisie.Row To zsaisie.Row + zsaisie.Rows.Count - 1
      If jour = Cells(i, "a") Then d(Cells(i, "b").Value) = "": d(Cells(i, "c").Value) = ""
    Next i
    Set d2 = CreateObject("scripting.dictionary")   ' reste
    For Each c In [liste]
       If Not d.exists(c.Value) Then d2(c.Value) = ""
    Next c
    Me.ComboBox1.List = d2.keys
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Click()
ActiveCell = Me.ComboBox1
End Sub

Avec des cellules discontinues

DVDiff discontinu

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

Choix d'activités complémentaires

Chaque élève choisit 5 activités complémentaires avec un ordre de choix. Chaque activité ne doit être choisie qu'une fois.

Dv Activités
Dv Activités form
Dv Activités formMAC
Dv Activités form2

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
     [M4:M8].ClearContents
     For Each c In [ListeActivites]
       If IsError(Application.Match(c, Range(Cells(Target.Row, "f"), Cells(Target.Row, "j")), 0)) Then
          [M65000].End(xlUp).Offset(1, 0) = c
      End If
    Next c
  End If
End Sub

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([planning], Target) Is Nothing Then
    [L2:L100].ClearContents
    For Each c In [ListeNoms]
      If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) Then
         [L65000].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([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Font.ColorIndex = [ListeNoms].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([planning], Target) Is Nothing Then
  temp = ""
  For Each c In [ListeNoms]
    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([planning], Target) Is Nothing Then
    temp = ""
    For Each c In [bureaux]
      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 - [planning].Column + 1
    LigActiv = Target.Row - [planning].Row + 1
    For Each c In [listeNoms]
      LigNom = Application.Match(c, [listeNoms], 0)
      a = Range("planning").Value
      dispo = IsError(Application.Match(c, Application.Index(a, , ColDate), 0))
      temAbs = Application.Index([Absences], LigNom, ColDate)
      If temAbs = "" And dispo Then
         [I65000].End(xlUp).Offset(1) = c
         If Application.CountA([planning]) > 0 Then _
            [I65000].End(xlUp).Offset(, 1) = Application.CountIf([planning], c) / Application.CountA([planning])
       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 [SALLES]
      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)
  [A1].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 vers DVSource.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").[A2].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 = [liste].Find(Target, LookAt:=xlWhole).Row
        col = [liste].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 = [liste].Find(Target, LookAt:=xlWhole).Row
    col = [liste].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([noms], , 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 = [liens].Find(what:=Target).Hyperlinks(1).SubAddress
    a = Split(temp, "!")
    Application.Goto Reference:=Sheets(a(0)).Range(a(1))
  End If
End Sub

DVLien
HyperLienDéroulant
HyperlienDéroulant2

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

1ere méthode

Au moment du choix dans le menu, on écrit une formule qui pointe vers la cellule de la liste.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([saisieChoix], Target) Is Nothing Then
    Application.EnableEvents = False
    p = Application.Match(Target, [Liste], 0)
    Set mc = Worksheets("feuil2").[Liste].Cells(p, 1)
    Target.Formula = "=Feuil2!" & mc.Address
    Application.EnableEvents = True
  End If
End Sub

2e méthode

Pour chaque item modifié dans la liste, on explore tous les choix déjà faits dans les menus

DVLiaison
DVLiaisonLangue

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([Liste], 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, [maListe], 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
    [maliste].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
DVmaj2

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
     Application.EnableEvents = False
     ValSaisie = Target.Value
     Application.Undo
     AncVal = Target
     For i = 1 To [listeChoix].Count
       If Sheets("choix").Range("listeChoix")(i) = AncVal Then  Sheets("choix").Range("listeChoix")(i) = ValSaisie
     Next i
     Target = ValSaisie
     Application.EnableEvents = True
   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 [Salles]
          If Not mondico.Exists(c.Value) Then
             [I65000].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

Activités complémentaires

Pour chaque personne, on choisit 5 activités. Chaque activité ne peut être choisie qu'une fois.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    [M4:M8].ClearContents
    For Each c In [ListeActivites]
      If IsError(Application.Match(c, Range(Cells(Target.Row, "f"), Cells(Target.Row, "j")), 0)) Then
          [M65000].End(xlUp).Offset(1, 0) = c
      End If
    Next c
  End If
End Sub

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([planning], Target) Is Nothing Then
    [J2:K100].ClearContents
    For Each c In [listeNoms]
       colNom = Application.Match(c, [listeNoms], 0)
       ligAct = Target.Column - 1
       dispo = Application.Index([grille], ligAct, colNom)
       ligDate = Target.Row - 3
       temAbs = Application.Index([absence], ligDate, colNom)
       If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) _
          And dispo And Not temAbs Then
            [J65000].End(xlUp).Offset(1, 0) = c
          tauxOccup = Application.CountIf([planning], c)
          If Application.CountA([planning]) > 0 Then
             [J65000].End(xlUp).Offset(0, 1) = tauxOccup / Application.CountA([planning])
          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
   [planning].ClearContents
   For lig = 1 To [planning].Rows.Count
     d = Cells(lig + [planning].Row - 1, 1)
     If Weekday(d, 2) < 6 Then
       For col = 1 To [planning].Columns.Count
         nbnoms = 0
         For Each c In [listeNoms]
            colNom = Application.Match(c, [listeNoms], 0)
            dispo = Application.Index([grille], col, colNom)
            temAbs = Application.Index([absence], lig, colNom)
            b = Application.Transpose([planning].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([planning], c)
               If Application.CountA([planning]) > 0 Then
                  taux(nbnoms) = tauxOccup / Application.CountA([planning])
               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
DVCompétences Diff

Listes déroulantes liées

On peut choisir le code ou le nom du département.

DVLiés

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:A10], Target) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    Target.Offset(, 1) = Application.Index([BD], , 1).Find(Target).Offset(, 1)
    Application.EnableEvents = True
  End If
  If Not Intersect([B2:B10], Target) Is Nothing And Target.Count = 1 Then
     Application.EnableEvents = False
     Target.Offset(, -1) = Application.Index([BD], , 2).Find(Target).Offset(, -1)
     Application.EnableEvents = True
  End If
End Sub

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

ComboBox pour remplacer Données/Validation

Affiche un commentaire au survol des options du combobox.

ComboBox Bulle
ComboBox Bulle couleur

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.22))
  If Ligne < Me.ComboBox1.ListCount Then
     On Error Resume Next
     Me.TextBox1 = ComboBox1.List(Ligne + Me.ComboBox1.TopIndex, 1)
  End If
End Sub

ComboBox 2 colonnes pour remplacer Données/Validation

Affiche un commentaire dans la 2e colonne du combobox.

ComboBox 2 colonnes

Données/Validation avec Filtre Automatique

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([F2:F2], Target) Is Nothing Then
     [A2].CurrentRegion.AutoFilter field:=3, Criteria1:="Oui"
     For Each C In Range("A3:A1000").SpecialCells(xlCellTypeVisible)
        temp = temp & C.Value & ","
     Next C
     temp = Left(temp, Len(temp) - 1)
     Target.Validation.Delete
     If Len(temp) > 0 Then Target.Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=temp
   End If
End Sub

Particularités de 2019

Pour obtenir une liste sans doublons en E2

DV villes sans doublons

Pour obtenir une liste des villes avec un tableau structuré, il faut utiliser =Indirect("villes")

DV villes tableau structuré