Les formulaires

Accueil

Créer un formulaire
Les contrôles: TextBox,Label,..
Afficher le formulaire(Show)
Ordre de saisie
Initialisation du formulaire
Transfert du formulaire dans le tableur
Vérification doublon
Differentes façons d'alimenter une liste déroulante
Collection des contrôles d'un formulaire
ComboBox Nom+Prénom
Vérifier la saisie de toutes les zones
Empêcher la fermeture d'un formulaire
Contrôle par défaut

Multicolonnes
ChampsIndicés
SansDoublons
Listes en cascade
Transfert
MultiSélection
Contrôles
Saisie numérique & dates
Contrôles tableur BO contrôles
Contrôles tableur BO formulaire


-Consultation- Modification- boutons suivant/précédent
-Recherche/modification doublons intuitif
-
Formulaire de consultation-modification général
-Recherche par nom+prénom
-Recherche BD (choix de la colonne)
-Recherche BD, Modif, Ajout
-Ajout liste
-Liste des feuilles classeur
-Liste macros modules
-Lien Hyper-texte sur formulaire
-Lien hypertexte ListBox
-Choix d'une photo dans un ComboBox
-Affichage image interne dans un formulaire
-Remplissage conditionnel d'un ComboBox
-Annuaire
-Saisie dans un tableau 2 dimensions
-Choix onglet
-
Zoom formulaire
-Coloriage
-Bulle listbox
-Affichage photo externe survol ListBox
-Affichage photo interne survol ListBox
-Formulaire de recherche
-Formulaire de saisie de 2 dates
-Formulaire de saisie BD avec 2 dates
-Liste fichiers d'un répertoire dans ListBox
-Choix de la colonne de tri
-Liste des feuilles d'un fichier XLS
-Facture
-Devis multi-lignes
-Choix d'une feuille
-Menu déroulant avec fichier fermé (ADO)
-ListBox couleur
-ListBox photo
-Renomme un fichier
-Message défilant dans userform
-Barre d'attente
-Liste des fichiers d'un répertoire
-Création de boutons
-Simulation listbox couleur
-Simulation ListBox image arrière-plan
-Editeur de cellule
-Recherche un mot dans tout le classeur
-Recherche un mot dans une colonne de BD
-Recherche avec les premières lettres
-Accès rapide
-Liste des fichiers d'un répertoire
-Masque de saisie téléphone
-Simulation ListBox couleur


Show
Unload
TextBox
ComboBox
RowSource
AddItem
RemoveItem
SetFocus

ListIndex
ListCount
List

Column
Clear
Controls
TypeName

Créer un formulaire

  • Alt+F11 pour accéder à VBA
  • Insertion/Userform

Visualisation d'une fiche

FormVisu

Private Sub UserForm_Initialize()
Set f = Sheets("BD")
For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  Me.ComboBox1.AddItem c
Next c
End Sub

Private Sub ComboBox1_Click()
  Set f = Sheets("BD")
  ligne = Me.ComboBox1.ListIndex + 2
  Me.TextBox1 = f.Cells(ligne, 2)
  Me.TextBox2 = f.Cells(ligne, 3)
  Me.TextBox3 = f.Cells(ligne, 4)
  Me.TextBox4 = f.Cells(ligne, 5)
End Sub

S'il y a au moins 2 lignes dans la BD, la boucle

For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  Me.ComboBox1.AddItem c
Next c

peut être remplacée par

 Me.ComboBox1.List=f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value

Autre version

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Me.ComboBox1.List = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
End Sub

Private Sub ComboBox1_Click()
  For i = 1 To 4
    Me("textbox" & i) = Me.ComboBox1.Column(i)
  Next i
End Sub

Création d'une fiche

Formulaire création simple
Formulaire Création Pièces Ventes

Private Sub UserForm_Initialize()
  Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
  Me.Ville.List = Array("Boulogne", "Lyon", "Paris", "Versailles")
End Sub

Private Sub b_validation_Click()
'--- Positionnement dans la base
ligne =Sheets("BD"). [A65000].End(xlUp).Row + 1
'--- Transfert Formulaire dans BD
Sheets("BD").Cells(ligne, 1) = Application.Proper(Me!nom)
Sheets("BD").Cells(ligne, 2) = CVDate(Me.date_naissance)
Sheets("BD").Cells(ligne, 3) = Me.Service
Sheets("BD").Cells(ligne, 4) = Me.Ville
Sheets("BD").Cells(ligne, 5) = CDbl(Me.Salaire)
End Sub

Private Sub b_fin_Click()
Unload Me
End Sub

Boite à outils

Affichage/Boîteà outils

Les différents types de contrôles d’un formulaire

Textbox

Pour créer la zone de saisie du nom :

  • Cliquer sur l’icône de la boîte à outils(Affichage/Boîte à outils)
  • Dessiner la zone de saisie dans le formulaire
  • Définir le nom de la zone de saisie dans la fenêtre Propriétés(nom)

Label

Pour créer le libellé Nom :

  • Cliquer sur l’icône de la boîte à outils
  • Frapper le libellé Nom

ComboBox

  • Cliquer sur l’icône
  • Nommer le menu Service

Pour alimenter un ComboBox ou une ListBox, on spécifie dans la propriété RowSource

-le champ de la liste (B2:B5)
-ou le nom du champ (maListeSimple).

Pour gérer les ajouts, le nom de champ peut être dynamique: =DECALER($B$2;;;NBVAL($B:$B)-1)

La propriété RowSource peut être alimentée par VBA

Private Sub UserForm_Initialize()
  Me.ComboBox1.RowSource = "B2:B" & [B65000].End(xlUp).Row
End Sub

Private Sub UserForm_Initialize()
  Me.ComboBox1.RowSource = "Feuil2!B2:B5" ' autre feuille
  'ou Me.ComboBox1.RowSource = "Feuil2!B2:B" & Sheets("Feuil2").[B65000].End(xlUp).Row
  'ou Me.ComboBox1.RowSource = "liste4" ' nom de champ
End Sub

Si la liste est dans un autre classeur ouvert

Me.ComboBox1.RowSource = "'[ClasseurSource.xls]Feuil1'!A2:A10"
Me.ComboBox1.RowSource = "'[ClasseurSource.xls]Feuil1'!LaListe"

Propriété List

Il faut au moins 2 éléments dans le tableau ou le champ

Private Sub UserForm_Initialize()
  Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
  Me.Ville.List = Array("Boulogne", "Lyon", "Paris", "Versailles")
End Sub

Private Sub UserForm_Initialize()
   Set f = Sheets("feuil2")
   Me.ComboBox1.List = Range(f.[A2], f.[A65000].End(xlUp)).Value
End Sub

Si une liste est en ligne

Me.ComboBox1.List = Application.Transpose([A2:D2])

ou

Me.ComboBox1.Column =[A2:D2]

Avec un dictionnaire

Il peut y avoir un seul élément dans le dictionnaire.

Set d = CreateObject("Scripting.Dictionary")
d.Item("aa") = ""
Me.ComboBox1.List = d.keys

Propriété Column

Si une liste est dans une ligne

Me.ComboBox1.Column = Range("C3:G3").Value

Récupération du choix

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

Positionnement sur le premier élément de la liste

Private Sub UserForm_Initialize()
   Me.ComboBox1.ListIndex = 0 "positionne sur le premier élément
End Sub

Case à cocher

Une case à cocher returne la valeur VRAI ou FAUX

Pour obtenir OUI ou NON, utiliser la fonction ci-dessous.

Function OuiNon(valeur)
  OuiNon = IIf(valeur, "Oui", "Non")
End Function

Groupe d’options civilité

  • Dessiner un cadre avec
  • Lenommer civilité

  • Dessiner des cases d'options à l'intérieur du cadre

Pour connaître l'option choisie dans un groupe, utiliser une boucle For Each x In Groupe.Controls.

Sur l'exemple, on récupère le libellé de l'option (propriété Caption) .

Private Sub B_ok_Click()
  temp = ""
  For Each c In Me.Civilité.Controls
     If c.Value Then temp = c.Caption
  Next c
  MsgBox temp 
End Sub

Vérifier q'une option a été choisie.

Private Sub B_ok_Click()
  témoin = False
  For Each c In Me.civilité.Controls
     If c.Value Then témoin = True
  Next c
  If Not témoin Then MsgBox "Aucun choix dans " & civilté.Caption
End Sub

Afficher le formulaire

Show vbModal ou vbModeless

  • Le nommer F_création_simple
  • Créer une macro dans un module

Sub appel_Simple()
  F_création_simple.Show
End Sub

Créer un bouton avec la barre d’outils Formulaires et lui affecter la macro

Clic-droit/Affecter une macro

Fermer un formulaire

Unload formulaire

Private Sub B_fin_Click()
  Unload Me        ' Formullaire actif
End Sub

Positionner le curseur

champ.setFocus

Champ.SetFocus Positionne le curseur sur le champ spécifié.

Me.Nom.SetFocus

Limiter le choix du service à la liste

Positionner la propriété MatchRequery à true

Définir la position d’affichage du formulaire

Positionner la propriété StartUpPosition à Manual puis définir les valeurs des propriétés Left et Top

Ordre de saisie

La commande Affichage / Ordre de tabulation permet de définir l’ordre de saisie.

Initialisation du formulaire

Pour initialiser les menus déroulants avec l'événement Initialize du formulaire:

  • Double-cliquer sur le formulaire
  • Choisir en haut à droite l'événement Initialize

Transfert des zones saisies dans la feuille de calcul

  • Créer un bouton
  • Le nommer B_validation
  • Double-clic sur le bouton

Formulaire Création
Form consultation simple
Form modification
Form modification/création

Private Sub UserForm_Initialize()
Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
Me.Ville.List = Array("Boulogne", "Lyon", "Paris", "Versailles")
End Sub

Private Sub b_validation_Click()
  '--- Contrôles
  If Me.nom = "" Then
    MsgBox "Saisir un nom!"
    Me.nom.SetFocus
    Exit Sub
  End If
  If Me.Salaire = "" Then
    MsgBox "Saisir un Salaire!"
    Me.nom.SetFocus
    Exit Sub
  End If
  '-- Date?
  If Not IsDate(Me.date_naissance) Then
    MsgBox "Saisir une date!"
    Me.date_naissance = ""
    Me.date_naissance.SetFocus
    Exit Sub
  End If
  Me.Salaire = Replace(Me.Salaire, ".", ",")
  If Not IsNumeric(Me.Salaire) Then
    MsgBox "Saisir du num!"
    Me.Salaire = ""
    Me.Salaire.SetFocus
    Exit Sub
  End If
  '--- Positionnement dans la base
  ligne =Sheets("BD"). [A65000].End(xlUp).Row + 1
  '--- Transfert Formulaire dans BD
  Sheets("BD").Cells(ligne, 2) = Application.Proper(Me!nom)
  Sheets("BD").Cells(ligne, 3) = Me.Marié
  Sheets("BD").Cells(ligne, 4) = CVDate(Me.date_naissance)
  Sheets("BD").Cells(ligne, 5) = Me.Service
  Sheets("BD").Cells(ligne, 6) = Me.Ville
  Sheets("BD").Cells(ligne, 7) = CDbl(Me.Salaire)
  '-- Civilité
  temp = ""
  For Each c In Me.Civilité.Controls
    If c.Value = True Then
      temp = c.Caption
    End If
  Next c
  Sheets("BD").Cells(ligne, 1) = temp
  nettoie
End Sub

Sub nettoie()
  Me.nom = ""
  Me.date_naissance = ""
  Me.Service = ""
  Me.Ville = ""
  Me.Salaire = ""
  For Each c In Me.Civilité.Controls
    c.Value = False
  Next c
  Me.Marié = False
End Sub

Private Sub b_fin_Click()
  Unload Me
End Sub

Vérification doublons

Ci dessous,la vérification est faite sur l'événement BeforeUpdate

Private Sub nom_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
  Set f = Sheets("BD")
  temp = Application.Match(Me.nom, f.[A2:A10000], 0)
  If Not IsError(temp) Then
    MsgBox "Doublon"
    Cancel = True
    Exit Sub
  End If
End Sub

SaisieAntiDoublons
SaisieAntiDoublonNomPrénom

Différentes façons d’alimenter une liste déroulante dynamique avec VBA

Rowsource

Nous modifions la propriété Rowsource

Me.Service.RowSource = "J2:" & "J" & [B65000].End(xlUp).Row
Me.Service.RowSource =”Maliste”                          ' nom de champ
Me.ComboBox1.RowSource = "Additem!B2:B5"     ' autre feuille

AddItem élément,position

AddItem ajoute un élément à un comboBox ou ListBox.

Private Sub UserForm_Initialize()
   Me.Service.AddItem "Etudes"
   Me.Service.AddItem "Informatique"
   Me.Service.AddItem "Marketing"
   Me.Service.AddItem "Production"
   '---
   Me.Ville.AddItem "Boulogne"
   Me.Ville.AddItem "Lyon"
   Me.Ville.AddItem "Paris"
   Me.Ville.AddItem "Versailles"
 End Sub

RemoveItem position,nombre

RemoveItem supprime un élément d’un comboBox ou ListBox.

ListIndex
ListIndex=position

ListIndex donne la position de l’élément choisi.

MsgBox ListBox1.ListIndex

ListIndex=position  positionne sur la position spécifiée.

Me.ListBox1.ListIndex = 3   ‘ positionne sur le 4eme

ListIndex=-1 supprime la sélection

Me.ListBox1.ListIndex = -1

Propriété List

La propriété List attend un tableau ou un champ vertical.

Private Sub UserForm_Initialize()
   Dim Tbl(1 To 7, 1 To 2)
   For j = 1 To 7
      Tbl(j, 1) = Format(Date + j - 1, "dddd")
      Tbl(j, 2) = Date + j - 1
   Next j
   Me.ListBox1.ColumnCount = 2
   Me.ListBox1.ColumnWidths = "40,60"
   Me.ListBox1.List = Tbl
End Sub

Pour récupérer le champ A2:A10

Me.comboBox1.List=Range("A2:A10").value

Il faut que le champ est au moins 2 cellules.

Pour un champ horizontal

Me.comboBox1.List=Application.Transpose(Range("A2:M2"))

La propriété List permet également de récupèrer dans un tableau la liste d’un ComboBox avec ListBox

  Tbl = Me.ListBox1.List
  MsgBox UBound(Tbl, 1)
  MsgBox LBound(Tbl, 1)

List(ligne,colonne)

Donne la valeur de la ligne et colonne spécifiées

Propriété Column

La propriété Column attend un tableau horizontal.

Private Sub UserForm_Initialize()
  Me.ComboBox1.Column = [noms].Value
End Sub

Column(noColonne)

Donne la valeur de la colonne spécifiée:

Me.TextBox1 = Me.ListBox1.Column(1)

Le no de première colonne est 0

ListCount

Donne le nombre de lignes du ComboBox ou ListBox

  MsgBox ListBox1.ListCount

Clear

Efface les options du ComboBox ou ListBox

Collection des contrôles d’un formulaire

TypeName(contrôle)

Une boucle For Each c  In Me.controls permet d’accéder à tous les contrôles du formulaire actif. TypeName(contrôle) retourne le type d'un contrôle: Textbox, Checkbox,ListBox,...

Dim c As Control
For Each c In Me.Controls
      MsgBox c.Name & " " & TypeName(c)
Next

Raz des contrôles d’un formulaire.

Private Sub B_raz_Click()
  Dim c As Control
  For Each c In Me.Controls
    Select Case TypeName(c)
       Case "TextBox"
          c.Value = ""
       Case "CheckBox"
          c.Value = False
       Case "ListBox", "ComboBox"
          c.ListIndex = -1
       Case "Frame"
          For Each b In c.Controls
            If TypeName(b) = "OptionButton" Then b.Value = False
          Next b
     End Select
   Next c
End Sub

Verrouillage des contrôles d'un formulaire.

Dim c As Contro
For Each c In Me.Controls
  Select Case TypeName(c)
    Case "TextBox", "CheckBox", "ListBox", "ComboBox",  "OptionButton", "Frame"
        c.Enabled = False
  End Select
Next c

Véfifier que toutes les zones ont bien été saisies

Dans le code du bouton de validation, nous parcourons tous les contrôles
pour s'assurer que les textbox et combobox sont bien remplis.

Private Sub B_validation_Click()
  Dim c As Control
  For Each c In Me.Controls
    Select Case TypeName(c)
      Case "TextBox", "ComboBox"
        If c.Value = "" Then
           MsgBox "Saisir cette zone!"
           c.SetFocus
           Exit Sub
        End If
     End Select
   Next c
   MsgBox "ok"
End Sub

Version avec checkBox

Private Sub UserForm_Initialize()
   Me.CheckBox1 = Null
End Sub

Private Sub B_Valid_Click()
  Dim c As Control
  For Each c In Me.Controls
    Select Case TypeName(c)
      Case "TextBox", "ComboBox"
         If c.Value = "" Then
           MsgBox "Saisir cette zone!"
           c.SetFocus
           Exit Sub
         End If
     Case "CheckBox"
        If IsNull(c.Value) Then
          MsgBox "Saisir cette zone!"
          c.SetFocus
          Exit Sub
        End If
     End Select
   Next c
   MsgBox "ok"
End Sub

Mettre tous les TextBox au format € après la saisie

Dim c As Control
For Each c In Me.Controls
  tmp = Replace(c, ".", ",")
  If TypeName(c) = "TextBox" And IsNumeric(tmp) Then
    c = Format(tmp, "####.## €")
  End If
Next c

Contrôle actif

ActiveControl.Name donne le nom du contrôle actif.

ComboBox avec nom+prénom

Fconsult3

Private Sub UserForm_Initialize()
  i = 0
  Me.Nom.Clear
  For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
     Me.Nom.AddItem
     Me.Nom.List(i, 0) = c & " " & c.Offset(0, 1)
     Me.Nom.List(i, 1) = c.Row
     i = i + 1
   Next c
   Me.Nom.ListIndex = 0
End Sub

Private Sub Nom_Change()
   If Me.Nom.ListIndex <> -1 Then
      i = Val(Me.Nom.Column(1))
      If i <> 0 Then
        Me.Adresse = Sheets("BD").Cells(i, 3).Value
        Me.Tel = Sheets("BD").Cells(i, 4).Value
        Me.Tel.Value = Format(Tel.Value, "00"" ""00"" ""00"" ""00"" ""00")
        Me.Portable = Sheets("BD").Cells(i, 5).Value
        Me.Portable.Value = Format(Portable.Value, "00"" ""00"" ""00"" ""00"" ""00")
        Me.Date_de_Naissance = Sheets("BD").Cells(i, 6).Value
     End If
  End If
End Sub

Image d’arrière plan (Picture/PictureAlignement/PictureSizeMode)

Empêcher la fermeture d'un formulaire

Sur cet exemple, on ne veut pas que le formulaire puisse être fermé avec la croix.

Barre attente

Le formulaire F_BarreAttente est non modal (showmodal=False)

Public témoin As Boolean
Sub Attente()
  n = 20                                    ' nb de fichiers à traiter
  témoin = True ' pour empêcher fermeture du formulaire
  F_BarreAttente.Show
  For f = 1 To n
    '-- simulation traitement fichier
    For a = 1 To 50000000: Next a ' Simulation attente
      '--------------
     p = p + 1 / n ' calcul du pourcentage
     F_BarreAttente.Label1.Width = p * 100
     F_BarreAttente.Caption = Format(p, "0%")
     DoEvents
  Next f
  témoin = False
  Unload F_BarreAttente
End Sub

Pour empêcher la fermeture du formulaire:

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Cancel = Not Témoin
End Sub

Définir le contrôle activé par défaut

Si l'utilisateur valide avec la touche Entrée, on veut que le bouton OK soit activé.
Dans la propriété Défault du bouton OK , choisir True

Exemples

Consultation - modification - boutons suivant/précédent

Form consultation simple
Form modification
Form Consult/Modification/Ajout trié
Form Consult/Modification/Ajout trié Camping

Affiche la fiche suivante/précédente.

Form consultation suivant précédent

Dim ligne
Dim maBD
Private Sub UserForm_Initialize()
  Set maBD = Sheets("BD")
  maBD.[A2:H2000].Sort key1:=maBD.[B2] ' Tri la BD
  Me.ChoixNom.List = Range(maBD.[B2], maBD.[B65000].End(xlUp)).Value
  Me.ChoixNom.ListIndex = 0
End Sub

Private Sub ChoixNom_Change()
  ligne = [B2].Offset(ChoixNom.ListIndex, 0).Row
  Me.nom = maBD.Cells(ligne, 2)
  Me.Marié = maBD.Cells(ligne, 3)
  Me.date_naissance = maBD.Cells(ligne, 4)
  Me.service = maBD.Cells(ligne, 5)
  Me.ville = maBD.Cells(ligne, 6)
  Me.Salaire = maBD.Cells(ligne, 7)
  '-- civilité
  For Each c In Me.Civilité.Controls
    If maBD.Cells(ligne, "a") = c.Caption Then c.Value = True
  Next c
  '---
  Répertoire = ThisWorkbook.Path
  If Dir(Répertoire & "\" & Me.nom & ".jpg") <> "" Then
    Me.Image1.Picture = LoadPicture(Répertoire & "\" & Me.nom & ".jpg")
  Else
    Me.Image1.Picture = LoadPicture
  End If
End Sub

Private Sub B_suivant_Click()
 If Me.ChoixNom.ListIndex < Me.ChoixNom.ListCount - 1 Then
   Me.ChoixNom.ListIndex = Me.ChoixNom.ListIndex + 1
  End If
End Sub

Private Sub b_précédent_Click()
  If Me.ChoixNom.ListIndex > 0 Then
    Me.ChoixNom.ListIndex = Me.ChoixNom.ListIndex - 1
  End If
End Sub

Private Sub b_fin_Click()
   Unload Me
End Sub

Formulaire de consultation/modification/Ajout trié

Le combobox ChoixNom est trié.

Form Consultation Modification Ajout Trié

Dim f, ligneEnreg
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Clé = f.Range("B2:B" & f.[B65000].End(xlUp).Row)
  Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
  Me.Loisirs.List = Array("Lecture", "Cinéma", "Vélo", "Natation", "Internet")
  '-------------avec tri---------------
  Call Tri(Clé, LBound(Clé), UBound(Clé))
  Me.ChoixNom.List = Clé
  Me.ChoixNom.ListIndex = 0
End Sub

Private Sub ChoixNom_Click()
  ligneEnreg = Sheets("BD").[B:B].Find(ChoixNom, LookIn:=xlValues).Row
  Me.nom = f.Cells(ligneEnreg, 2)
  Me.Marié = f.Cells(ligneEnreg, 3)
  Me.Date_naissance = f.Cells(ligneEnreg, 4)
  Me.Service = f.Cells(ligneEnreg, 5)
  Me.Ville = f.Cells(ligneEnreg, 6)
  Me.Salaire = f.Cells(ligneEnreg, 7)
  '-- civilité
  For Each c In Me.Civilité.Controls
    If f.Cells(ligneEnreg, "a") = c.Caption Then c.Value = True
  Next c
  '--- loisirs
  temp = f.Cells(ligneEnreg, 8)
  a = Split(temp, ";")
  For j = 0 To Me.Loisirs.ListCount - 1: Me.Loisirs.Selected(j) = False: Next j
  If UBound(a) >= 0 Then
     For j = 0 To Me.Loisirs.ListCount - 1
       If Not IsError(Application.Match(Me.Loisirs.List(j), a, 0)) Then
           Me.Loisirs.Selected(j) = True
       Else
           Me.Loisirs.Selected(j) = False
       End If
    Next j
  End If
End Sub

Private Sub B_validation_Click()
  If Me.nom = "" Then
    MsgBox "Saisir un nom"
    Me.nom.SetFocus
    Exit Sub
  End If
  If Not IsDate(Me.Date_naissance) Then
    MsgBox "Saisir une date"
    Me.Date_naissance.SetFocus
    Exit Sub
  End If
  If Not IsNumeric(Me.Salaire) Then
    MsgBox "Saisir un salaire"
    Me.Salaire.SetFocus
    Exit Sub
  End If
  '--- Transfert Formulaire dans BD
  f.Cells(ligneEnreg, 2) = Application.Proper(Me!nom)
  f.Cells(ligneEnreg, 3) = Me.Marié 'OuiNon(Me.Marié)
  f.Cells(ligneEnreg, 4) = CVDate(Me.Date_naissance)
  f.Cells(ligneEnreg, 5) = Me.Service
  f.Cells(ligneEnreg, 6) = Me.Ville
  f.Cells(ligneEnreg, 7) = CDbl(Me.Salaire)
  '-- Civilité
  temp = ""
  For Each c In Me.Civilité.Controls
   If c.Value = True Then
      temp = c.Caption
   End If
  Next c
  f.Cells(ligneEnreg, 1) = temp
  '-- loisirs
  temp = ""
  For i = 0 To Me.Loisirs.ListCount - 1
    If Me.Loisirs.Selected(i) = True Then temp = temp & Me.Loisirs.List(i) & ";"
  Next i
  f.Cells(ligneEnreg, 8) = temp
  UserForm_Initialize
End Sub

Private Sub B_sup_Click()
  If MsgBox("Etes vous sûr de suppimer " & f.Cells(ligneEnreg, 2) & "?", vbYesNo) = vbYes Then
    ncol = 8
    f.Cells(ligneEnreg, 1).Resize(, ncol).Delete Shift:=xlUp
    UserForm_Initialize
  End If
End Sub

Formulaire de modification général

Form général Consultation/modification/création
Form général Consultation/modification/création intuitif

Les noms des champs du formulaire sont les titres de la BD. On peut donc ajouter des champs dans la BD ou les déplacer sans modifier la programmation.

Option Compare Text
Dim f, ligneEnreg
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Clé = Application.Transpose(f.Range("A2:A" & f.[a65000].End(xlUp).Row).Value)
  Call Tri(Clé, LBound(Clé), UBound(Clé))
  Me.NomCherche.List = Clé
  ligneEnreg = f.[a65000].End(xlUp).Row + 1
  Me.Loisirs.List = Array("Lecture", "Cinéma", "Vélo", "Natation", "Internet")
  Me.NomCherche.SetFocus
End Sub

Private Sub NomCherche_click()
  ligneEnreg = Sheets("BD").[A:A].Find(NomCherche, LookIn:=xlValues).Row
  For Each c In Me.Controls
   nom_control = c.Name
   If nom_control <> "NomCherche" Then
     col = Application.Match(nom_control, [titre], 0)
     Select Case TypeName(c)
        Case "TextBox"
             Me(nom_control) = f.Cells(ligneEnreg, col)
        Case "Frame"
             For Each opt In c.Controls
                If f.Cells(ligneEnreg, col) = opt.Caption Then opt.Value = True
             Next opt
         Case "ListBox"
             temp = f.Cells(ligneEnreg, col)
             a = Split(temp, ";")
             For j = 0 To Me(nom_control).ListCount - 1: Me(nom_control).Selected(j) = False: Next j
             If UBound(a) >= 0 Then
                For j = 0 To Me(nom_control).ListCount - 1
                   If Not IsError(Application.Match(Me(nom_control).List(j), a, 0)) Then
                      Me(nom_control).Selected(j) = True
                   Else
                      Me(nom_control).Selected(j) = False
                   End If
                Next j
             End If
        End Select
     End If
  Next c
  Me.Nom.SetFocus
End Sub

Formulaire de consultation/modification doublons avec saisie intuitive

-L'opérateur frappe les premières lettres du nom cherché.
-Les noms en doublon sont affichés dans une ListBox.
-Les libellés des champs du formulaire s'adaptent automatiquement aux titres de la BD. On peut déplacer des champs de la BD ou en ajouter sans modifier le programme.

Form Consultation/modification doublons intuitif

Recherche par nom +prénom

Recherche Nom + prénom
Recherche Nom + prénom intuitif



Option Compare Text
Dim f, ligneEnreg, Tblclé(), tblBD()
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:B" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  tblBD = Range("A2:G" & [A65000].End(xlUp).Row).Value ' BD
  Call Tri2col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

Version avec index dans la troisième colonne du ComboBox

Sur cette version, on ajoute dans la troisième colonne de la table TblClé() les numéros d'enregistrements pour retrouver plus tard directement l'enregistrement choisi dans le combobox

Recherche Nom + prénom avec no enreg

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:C" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  For i = 1 To UBound(Tblclé): Tblclé(i, 3) = i+1: Next i   ' Index dans la troisième colonne
  Call Tri2Col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

L'enregistrement choisi dans le combobox est retrouvé avec :

ligneEnreg = Me.ChoixNom.Column(2)

Doublons sur Nom+prénom

On affiche la ville dans le ComboBox de recherche

Recherche Nom + prénom + ville avec no enreg

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:D" & [A65000].End(xlUp).Row).Value             ' Nom+Prénom
  For i = 1 To UBound(Tblclé): Tblclé(i, 3) = f.Cells(i + 1, 7): Next i ' ville
  For i = 1 To UBound(Tblclé): Tblclé(i, 4) = i + 1: Next i                ' index
  Call Tri2Col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

Choix intuitif de la ville & du code postal dans un combobox

La liste des villes apparaît au fur et à mesure de la frappe des caractères.

Form Saisie Ville CodePostal Intuitif

Recherche dans une colonne de BD (choix de la colonne de recherche)

Sur cet exemple, on choisi la colonne de recherche dans un ComboBox.

Recherche BD
Recherche BD Intuitif
Recherche BD Photo

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  col = f.[iv1].End(xlToLeft).Column
  Me.ComboBox1.List = Application.Transpose(f.[a1].Resize(, col))
End Sub

Private Sub ComboBox1_click()
  col = Me.ComboBox1.ListIndex
  n = f.[a65000].End(xlUp).Row - 1
  Me.ComboBox2.List = f.[A2].Offset(, col).Resize(n).Value
  Me.choixitem.Caption = "choix " & Me.ComboBox1
End Sub

Private Sub ComboBox2_Click()
  ligneEnreg = Me.ComboBox2.ListIndex + 2
  For Z = 1 To 12
    Me("label" & Z).Caption = f.Cells(1, Z)
    Me("textbox" & Z) = f.Cells(ligneEnreg, Z)
  Next Z
End Sub

Recherche BD par nom, ville et activité + Modif +ajout

Recherche Modif Ajout BD

Ajout à une liste

Si l'élément frappé n'appartient pas à la liste, il est ajouté (Liste dans le tableur)

- FormAjoutListe -

Private Sub Choix_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  If IsError(Application.Match(Me.Choix, Range("liste"), 0)) And Me.Choix <> "" Then
    Range("liste").End(xlDown).Offset(1, 0) = Me.Choix
    Range("liste").Sort key1:=Range("liste")(1)
 End If
End Sub

Liste des feuilles du classeur actif

Private Sub UserForm_Initialize()
  For i = 1 To Sheets.Count
    Me.ComboBox1.AddItem Sheets(i).Name
  Next i
End Sub

Création de fiches achat/vente avec photos

Achat Vente
Formulaire Création Pièces Ventes

Dim bdAchat, répertoirePhoto
Private Sub UserForm_Initialize()
  Set bdAchat = Sheets("Achat")
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = bdAchat.Cells(lignefin, 1) + 1
  Me.TYpeAchat.List = Range("type").Value
  Me.Facture.List = Range("ouinon").Value
  Me.DateAchat = Date
  répertoirePhoto = "c:\mesdoc" ' Adapter
  nf = Dir(répertoirePhoto & "\*.jpg")
  Do While nf <> ""
    Me.ChoixPhoto.AddItem nf
    nf = Dir
  Loop
End Sub

Private Sub ChoixPhoto_click()
  Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & ChoixPhoto)
End Sub

Private Sub B_validation_Click()
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Dim c As Control
  For Each c In Me.Controls
     pos = Val(c.Tag)
     If pos <> 0 Then
       If IsNumeric(c) Then
         bdAchat.Cells(lignefin + 1, pos) = Val(c)
       Else
          If IsDate(c) Then
             bdAchat.Cells(lignefin + 1, pos) = CDate(c)
          Else
            bdAchat.Cells(lignefin + 1, pos) = c
          End If
        End If
       End If
     Next c
     raz
     Me.Id.SetFocus
     lignefin = bdAchat.[A65000].End(xlUp).Row
     Me.Id = bdAchat.Cells(lignefin, 1) + 1
     Me.Image1.Picture = LoadPicture
End Sub

Sub raz()
  Dim c As Control
  For Each c In Me.Controls
    Select Case TypeName(c)
      Case "TextBox", "ComboBox"
        c.Value = ""
     Case "Picture"
        c.Picture = LoadPicture
    End Select
  Next c
End Sub

Liste des macros des modules

La liste des procédures est affiché dans un formulaire non modal.

- ActiveSub -

Private Sub UserForm_Initialize()
' Outils/Macros/Sécurité/Sources fiables/Cocher Faire confiance au projet Visual Basic
  For Each c In ActiveWorkbook.VBProject.VBComponents
    For ligne = 1 To c.CodeModule.CountOfLines
      temp = Trim(c.CodeModule.Lines(ligne, 1))
      If Left(temp, 3) = "Sub" Then Me.ComboBox1.AddItem Mid(Left(temp, Len(temp) - 2), 4)
    Next
  Next
End Sub

Private Sub ComboBox1_Change()
   Application.Run Me.ComboBox1
End Sub

Private Sub Workbook_Open()
   UserForm1.Show
End Sub

Lien hyper-texte sur formulaire

- Form Hyper-Lien -

Private Sub MonLien_Click()
  On Error Resume Next
  ActiveWorkbook.FollowHyperlink Address:=Me.MonLien.Caption, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Changement couleur au survol

Private Sub Monlien_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 2 Or X > Monlien.Width - 2 Or Y < 5 Or Y > Monlien.Height - 5 Then
    Me.Monlien.ForeColor = RGB(0, 0, 0)
  Else
    Me.Monlien.ForeColor = RGB(255, 0, 0)
  End If
End Sub

Private Sub MonMail_Click()
  On Error Resume Next
  ActiveWorkbook.FollowHyperlink Address:="mailto:" & Me.MonMail.Caption, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Lien hypertexteListBox

ListBoxLien

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ListBox1.Clear
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = f.Cells(i, 1).Hyperlinks(1).Address
  Next i
End Sub

Private Sub ListBox1_Click()
  On Error Resume Next
  Err = 0
  ActiveWorkbook.FollowHyperlink Address:=Me.ListBox1.Column(1), NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

LienListBox
LienHyperFeuille

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub

Private Sub listbox1_Click()
  ligne = Me.ListBox1.ListIndex + 2
  temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
  On Error Resume Next
  Err = 0
  ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   ligne = Int(Y / (ListBox1.Font.Size * 1.18))
   If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
     Me.Curseur.Visible = True
     Me.Lien.Visible = True
     Me.Adr.Visible = True
     Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
     Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
     temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
     Me.Adr.Caption = temp
     Me.ListBox1.ListIndex = -1
   Else
     Me.Curseur.Visible = False
     Me.Lien.Visible = False
     Me.Adr.Visible = False
  End If
End Sub

Version avec curseur et validation sur double-clic

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub


Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   ligne = Int(Y / (ListBox1.Font.Size * 1.18))
   If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
     Me.Lien.Visible = True
     Me.Adr.Visible = True
     Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
     temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
     Me.Adr.Caption = temp
     Me.ListBox1.ListIndex = ligne + Me.ListBox1.TopIndex
   Else
     Me.Lien.Visible = False
     Me.Adr.Visible = False
   End If
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   ligne = Me.ListBox1.ListIndex + 2
   temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
   On Error Resume Next
   Err = 0
   ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
   If Err <> 0 Then MsgBox "Erreur"
End Sub

Choix d'une photo dans un ComboBox

La liste des photos est dans la colonne A

FormPhotoNom

Private Sub UserForm_Initialize()
  Me.ChoixPhoto.RowSource = "A2:" & "A" & [A65000].End(xlUp).Row ' nom de photos dans colonne A
End Sub

Private Sub ChoixPhoto_Change()
  répertoirePhoto = "c:\photos"
  If Dir(répertoirePhoto & "\" & Me.ChoixPhoto & ".jpg") <> "" Then
     Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & ChoixPhoto & ".jpg")
  Else
     Me.Image1.Picture = LoadPicture
  End If
End Sub

Autre version

La liste est remplie avec la liste des fichiers jpg du répertoire où est situé le classeur..

FormPhotoRep

Private Sub UserForm_Initialize()
   répertoire = ThisWorkbook.Path
   nf = Dir(répertoire & "\*.jpg")
   Do While nf <> ""
      Me.ChoixPhoto.AddItem nf
      nf = Dir
   Loop
End Sub

Private Sub ChoixPhoto_Change()
   répertoire = ThisWorkbook.Path
   Me.Image1.Picture = LoadPicture(répertoire & "\" & ChoixPhoto)
End Sub

 

Bouton Toggle avec image

L'image du bouton est modifiée si le bouton est enfoncé.

ToogleImage

Private Sub ToggleButton1_Click()
  Me.ToggleButton1.Picture = IIf(ToggleButton1, Me.Image1.Picture, Me.Image2.Picture)
End Sub

Affichage des photos d'un répertoire

Le répertoire est choisi par l'opérateur.

FormPhotoNom

Private Sub B_ChoixRep_Click()
  DossierChoisi = VoirDossier("Choisir le dossier") ' voir module mod_voir_dossier
  If DossierChoisi <> "" Then
    Me.Dossier = DossierChoisi
    ChDir DossierChoisi
    UserForm_Initialize
  End If
End Sub

Private Sub UserForm_Initialize()
  ChDir CurDir()
  Me.Dossier = CurDir()
  nf = Dir("*.*")
  n = 0
  Me.ListBox1.Clear
  Do While nf <> ""
    If UCase(Right(nf, 3)) = "JPG" Or UCase(Right(nf, 3)) = "GIF" Then
      Me.ListBox1.AddItem
      Me.ListBox1.List(n, 0) = nf
      Me.ListBox1.List(n, 1) = FileLen(nf)
      n = n + 1
    End If
    nf = Dir
  Loop
  If n > 0 Then
    Me.Image1.Picture = LoadPicture(Me.Dossier & "\" & Me.ListBox1.List(0, 0))
  End If
  Me.TextBox1 = n & " Fichiers"
End Sub

Private Sub ListBox1_Click()
  Me.Image1.Picture = LoadPicture(Me.Dossier & "\" & Me.ListBox1)
End Sub

DiaporamaFormulaire
DiaporamaFormPhotosInternes

Inversion image interne au survol dans un formulaire

FormImageInterneSurvol
FormImageExterneSurvol

Affichage d'une image interne dans un formulaire

En mode direct

Pour copier une image interne dans un contrôle image d'un formulaire, Edition/Copier puis dans la propriété Picture du contrôle Edition/Coller.

En VBA

FormImageInterne
Form Image Interne Stephen Bullen

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
    Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_Change()
  Set s = f.Shapes(CStr(Me.ComboBox1))
  s.CopyPicture
  f.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
End Sub

Autre solution

Les images sont encapsulées dans des contrôles Image

FormImageInterne3

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
     Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_Change()
  temp = Me.ComboBox1
  Me.Image1.Picture = f.OLEObjects(temp).Object.Picture
End Sub

Image Web dans un formulaire

FormImageWeb

Private Sub UserForm_Initialize()
  Set f = Sheets("feuil1")
  s = "https://www.google.fr/images/srpr/logo11w.png"
  Set img = ActiveSheet.Pictures.Insert(s)
  img.Left = 1
  img.Top = 1
  img.CopyPicture
  f.ChartObjects.Add(0, 0, img.Width, img.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
  img.Delete
End Sub

Création BD avec Photo

BDPhoto

Dim bdAchat, répertoirePhoto
Private Sub UserForm_Initialize()
  Set bdAchat = Sheets("Achat")
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = Val(bdAchat.Cells(lignefin, 1)) + 1
  Me.TYpeAchat.List = Range("type").Value
  Me.Facture.List = Range("ouinon").Value
  Me.DateAchat = Date
  répertoirePhoto = "c:\mesdoc" ' Adapter
  nf = Dir(répertoirePhoto & "\*.jpg")
  Do While nf <> ""
    Me.ChoixPhoto.AddItem nf
    nf = Dir
  Loop
End Sub

Private Sub ChoixPhoto_click()
  Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Me.ChoixPhoto)
End Sub

Private Sub B_validation_Click()
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Dim c As Control
  For Each c In Me.Controls
    If TypeName(c) <> "Image" Then
      pos = Val(c.Tag)
      If pos <> 0 Then
        If IsNumeric(c) Then
        bdAchat.Cells(lignefin + 1, pos) = Val(c)
      Else
         If IsDate(c) Then
            bdAchat.Cells(lignefin + 1, pos) = CDate(c)
         Else
            bdAchat.Cells(lignefin + 1, pos) = c
         End If
      End If
    End If
  Else
     If Me.ChoixPhoto <> "" Then
       pos = Val(c.Tag)
       Set cel = bdAchat.Cells(lignefin + 1, pos)
       With bdAchat
         .Pictures.Insert(répertoirePhoto & "\" & Me.ChoixPhoto).Name = Me.ChoixPhoto
         .Shapes(Me.ChoixPhoto).Height = cel.Height - 2
         .Shapes(Me.ChoixPhoto).Left = cel.Left + (c.Width - .Shapes(Me.ChoixPhoto).Width) / 2 + 1
         .Shapes(Me.ChoixPhoto).Top = cel.Top + 1
         .Shapes(Me.ChoixPhoto).LockAspectRatio = msoTrue
       End With
     End If
   End If
  Next c
  raz
  Me.Id.SetFocus
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = bdAchat.Cells(lignefin, 1) + 1
  Me.Image1.Picture = LoadPicture
End Sub

Remplissage conditionnel d'un combobox

On veut remplir le combobox avec H ou F ou les deux.

RemplissageConditionnel

Private Sub OptionButton1_Click()
  RemplitCombo "H"
End Sub

Private Sub OptionButton2_Click()
  RemplitCombo "F"
End Sub

Private Sub OptionButton3_Click()
  RemplitCombo "*"
End Sub

Private Sub UserForm_Initialize()
  RemplitCombo "*"
End Sub

Sub RemplitCombo(Sexe)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
    If c.Offset(0, 1) Like Sexe Then
      If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
    End If
  Next c
  Me.ComboBox1.List = MonDico.items
  Me.ComboBox1.ListIndex = 0
End Sub

Version avec tri

Sub RemplitCombo(Sexe)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
     If c.Offset(0, 1) Like Sexe Then
        If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
     End If
  Next c
  temp = MonDico.items ' le tableau temp() reçoit les éléments de MonDico
  Call Tri(temp, LBound(temp), UBound(temp)) ' tri
  Me.ComboBox1.List = temp
  Me.ComboBox1.ListIndex = 0
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

Annuaire

Annuaire
AnnuaireParam
AnnuairePhoto
AnnuairePhoto2

Dim Btn(1 To 27) As New ClasseLettres
Dim ligne
Private Sub UserForm_Initialize()
    For b = 1 To 27: Set Btn(b).GrLettres = Me("B_" & b): Next b
    Sheets("BD").[A2:G5000].Sort key1:=Sheets("BD").[A2]
    '-- Liste des noms
    Me.Lettre = "*"
    majChoixNom
    ligne = 2
    majFiche
End Sub

Private Sub ChoixNom_Click()
  ligne = Sheets("BD").[A:A].Find(choixnom, LookIn:=xlValues).Row
  majFiche
End Sub

Sub majFiche()
   Me.nom = Sheets("BD").Cells(ligne, 1)
   Me.Service = Sheets("BD").Cells(ligne, 2)
   Me.Tph = Sheets("BD").Cells(ligne, 3)
   Me.Portable = Sheets("BD").Cells(ligne, 4)
   Me.Email = Sheets("BD").Cells(ligne, 5)
End Sub

Private Sub b_validation_Click()
   If Me.nom = "" Then
     MsgBox "Saisir un nom!"
     Me.nom.SetFocus
     Exit Sub
   End If
   Set temp = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues)
   If Not temp Is Nothing Then
      If temp.Row <> ligne Then
         MsgBox "Existe déjà!"
         Exit Sub
      End If
   End If
   '---- transfert base
   Sheets("bd").Cells(ligne, 1) = Application.Proper(Me.nom)
   Sheets("bd").Cells(ligne, 2) = Me.Service
   Sheets("bd").Cells(ligne, 3) = Me.Tph
   Sheets("bd").Cells(ligne, 4) = Me.Portable
   Sheets("bd").Cells(ligne, 5) = Me.Email
   Me.nom.SetFocus
   Sheets("BD").[A2:G5000].Sort key1:=Sheets("BD").[A2]
   ligne = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues).Row
   majChoixNom
End Sub

Private Sub B_ajout_Click()
   ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
   nettoie
End Sub

Private Sub B_sup_Click()
  rep = MsgBox("Etes vous sûr?", vbYesNo)
  If rep = vbYes Then
     Sheets("BD").Rows(ligne).Delete
     nettoie
     ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
     majChoixNom
   End If
End Sub

Sub nettoie()
   Me.nom = ""
   Me.Service = ""
   Me.Tph = ""
   Me.Portable = ""
   Me.Email = ""
   Me.nom.SetFocus
End Sub

Sub majChoixNom()
  Me.choixnom.Clear
  If Me.Lettre = "*" Then
    For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
      Me.choixnom.AddItem c
    Next c
  Else
      For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
        If Left(c.Value, 1) = Me.Lettre Then Me.choixnom.AddItem c
      Next c
  End If
End Sub

Private Sub b_fin_Click()
   Unload Me
End Sub

Private Sub B_suiv_Click()
   If Me.Lettre = "*" Then
     If ligne < Sheets("BD").[A65000].End(xlUp).Row Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne + 1
          majFiche
       End If
Else
    If Left(Sheets("bd").Cells(ligne + 1, 1), 1) = Me.Lettre Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne + 1
          majFiche
       End If
    End If
End Sub

Private Sub B_prec_Click()
  If Me.Lettre = "*" Then
     If ligne > 2 Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne - 1
          majFiche
       End If
   Else
      If Left(Sheets("bd").Cells(ligne - 1, 1), 1) = Me.Lettre Then
         If Me.nom <> "" Then b_validation_Click
           ligne = ligne - 1
           majFiche
         End If
      End If
End Sub

Module de classe

Public WithEvents GrLettres As MSForms.CommandButton
Private Sub GrLettres_Click()
   F_Lettre2.Lettre = GrLettres.Caption
   F_Lettre2.choixnom.Clear
      If GrLettres.Caption = "*" Then
        For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
          F_Lettre2.choixnom.AddItem c
        Next c
      Else
        For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
           If Left(c.Value, 1) = GrLettres.Caption Then F_Lettre2.choixnom.AddItem c
        Next c
      End If
      If F_Lettre2.choixnom.ListCount > 0 Then
         F_Lettre2.choixnom.ListIndex = 0
      End If
End Sub

Saisie dans un tableau à 2 dimensions

Noms de champ
Ca =DECALER($B$2;;;NBVAL($A:$A);NBVAL($1:$1))
Mois =DECALER($B$1;;;;NBVAL($1:$1))
produit =DECALER($A$2;;;NBVAL($A:$A))

- FormIndex -

Private Sub UserForm_Initialize()
  Me.ComboBox1.RowSource = "produit"
  Me.ComboBox2.List = Application.Transpose([mois])
End Sub

Private Sub CommandButton1_Click()
  If Not IsNumeric(Me.TextBox1) Then
     MsgBox "Saisir du num!"
  Else
     Application.Index([CA], Me.ComboBox1.ListIndex + 1, Me.ComboBox2.ListIndex + 1) = CDbl(Me.TextBox1)
  End If
End Sub

Choix d'un onglet dans un formulaire

Un formulaire non modal permet de sélectionner une feuille du classeur.

Private Sub UserForm_Initialize()
  For Each s In ActiveWorkbook.Sheets
    Me.ComboBox1.AddItem s.Name
  Next s
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
  m = Me.ComboBox1
  Sheets(m).Select
End Sub

La liste des onglets est affichée automatiquement au survol du formulaire. -Form Choix onglet -

Private Sub UserForm_Initialize()
  Dim temp()
  For i = 1 To Sheets.Count
    ReDim Preserve temp(1 To i)
    temp(i) = Sheets(i).Name
  Next i
  n = UBound(temp)
  Call Tri(temp, 1, n)
  Me.ComboBox1.List = temp
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Me.Show
  Me.ComboBox1.SetFocus
  SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  m = Me.ComboBox1
  Sheets(m).Select
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

Zoom formulaire en fonction de la taille de l'écran

Dans un module:
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Function largeurEcran()
  largeurEcran = GetSystemMetrics(0)
End Function

Formulaire:
Private Sub UserForm_Initialize()
  Me.Zoom = largeurEcran * 100 / 800
End Sub

Formulaire de coloriage

Les couleurs sont définies sur l'onglet couleurs

FormColoriage
FormColoriage2

Code formulaire

Dim Btn(1 To 10) As New ClasseBoutons
  Private Sub UserForm_Initialize()
  For i = 1 To 8
    Me("CommandButton" & i).BackColor = Sheets("couleurs").Cells(i, 1).Interior.Color
    Me("CommandButton" & i).ForeColor = Sheets("couleurs").Cells(i, 1).Font.Color
    Me("CommandButton" & i).Caption = Sheets("couleurs").Cells(i, 1)
    Set Btn(i).GrBoutons = Me("commandbutton" & i)
  Next i
End Sub

Module de classe ClasseBoutons

Public WithEvents GrBoutons As Msforms.CommandButton
  Private Sub GrBoutons_Click()
  Selection.Interior.Color = GrBoutons.BackColor
  Selection.Font.Color = GrBoutons.ForeColor
  Selection.Value = GrBoutons.Caption
End Sub

Version label

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

Bulle commentaire sur ListBox

ListBox avec curseur au survol

FormListBoxCurseurSurvol

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Lien.Visible = True
    Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
    Me.ListBox1.ListIndex = ligne + Me.ListBox1.TopIndex
  Else
    Me.Lien.Visible = False
  End If
End Sub

Un commentaire est affiché dans un TextBox en fonction de l'option survolée.

FormBulle
FormBulleCombo
FormBulleShape

Private Sub UserForm_Initialize()
   Me.ListBox1.List = [MaBD].Value
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.2))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.2 + Me.ListBox1.Top
    Me.TextBox1 = ListBox1.List(ligne + Me.ListBox1.TopIndex, 1)
  Else
    Me.Curseur.Visible = False
    Me.TextBox1 = ""
  End If
End Sub

Affichage d'une photo externe au survol d'un ListBox

SurvolListBoxImage
SurvolListBoxImage2

Private Sub UserForm_Initialize()
With Sheets("bd")
Me.ListBox1.List = .Range("A2:B" & .Range("A65000").End(xlUp).Row).Value
End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.ListBox1.ListIndex = -1
    répertoire = ThisWorkbook.Path
    photo = ListBox1.List(ligne + Me.ListBox1.TopIndex, 0) & ".jpg"
    If Dir(répertoire & "\" & photo) <> "" Then
      Me.Image1.Picture = LoadPicture(répertoire & "\" & photo)
    Else
     Me.Image1.Picture = LoadPicture
    End If
    Me.TextBox1 = ListBox1.List(ligne + Me.ListBox1.TopIndex, 1)
  Else
   Me.Curseur.Visible = False
  End If
End Sub

Affichage d'une photo interne au survol d'un ListBox

SurvolListBoxPhotoInterne
SurvolListBoxPhotoInterne2
SurvolListBoxPhotoInterne3

Public répertoirePhotos
Sub auto_open()
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("liste")
    lig = [Liste].Find(c, LookAt:=xlWhole).Row
    col = [Liste].Column + 1
    For Each s In f.Shapes
      If s.TopLeftCell.Address = Cells(lig, col).Address Then
        H = s.Height
        L = s.Width
        s.Copy
        f.ChartObjects.Add(0, 0, L, H).Chart.Paste
        f.ChartObjects(1).Border.LineStyle = 0
        f.ChartObjects(1).Chart.Export Filename:= _
        répertoirePhotos & c & ".jpg", FilterName:="jpg"
        f.ChartObjects(1).Delete
     End If
   Next s
  Next c
  UserForm1.Show
End Sub

Private Sub UserForm_Initialize()
  Me.ListBox1.List = [Liste].Value
  Me.TextBox2 = répertoirePhotos
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
     Me.Curseur.Visible = True
     Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
     Me.ListBox1.ListIndex = -1
     photo = ListBox1.List(ligne + Me.ListBox1.TopIndex, 0) & ".jpg"
     Me.TextBox1 = photo
     If Dir(répertoirePhotos & photo) <> "" Then
        Me.Image1.Picture = LoadPicture(répertoirePhotos & photo)
     Else
        Me.Image1.Picture = LoadPicture
     End If
  Else
    Me.Curseur.Visible = False
  End If
End Sub

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

Choix d'un hyper lien dans un listbox

HyperLienListBox

Private Sub UserForm_Initialize()
With Sheets(1)
Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Lien.Visible = True
    Me.Adr.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
    temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
    Me.Adr.Caption = temp
    Me.ListBox1.ListIndex = -1
  Else
    Me.Curseur.Visible = False
    Me.Lien.Visible = False
    Me.Adr.Visible = False
  End If
End Sub

Private Sub listbox1_Click()
ligne = Me.ListBox1.ListIndex + 2
temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
On Error Resume Next
Err = 0
ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
If Err <> 0 Then MsgBox "Erreur"
End Sub

Formulaire de recherche

Le zones de saisie du formulaire sont générées automatiquement en fonction des colonnes de la BD. Celle ci doit être située en A1.

FormRecherche

Dim f, nbCol, pointeur, ligne
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  ligne = 2
  nbCol = f.[A1].CurrentRegion.Columns.Count
  x = 11
  y = 15
  For i = 1 To nbCol
    retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
    Me("label" & i).Caption = f.Cells(1, i)
    Me("label" & i).Top = y
    Me("label" & i).Left = x
    retour = Me.Controls.Add("Forms.TextBox.1", "TextBox" & i, True)
    Me("textbox" & i).Top = y
    Me("textbox" & i).Left = x + 30
    Me("textbox" & i).Width = f.Columns(i).Width + 4
    y = y + 20
  Next
  retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
  Me("label" & i).Caption = f.Cells(1, 1)
  Me("label" & i).Top = Me.ListBox1.Top - 10
  Me("label" & i).Left = Me.ListBox1.Left + 2
  '--
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = i
  Next
  If nbCol > 8 Then Me.Height = y + 30
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub ListBox1_Click()
  ligne = Me.ListBox1.Column(1)
  pointeur = Me.ListBox1.ListIndex
  affiche
End Sub

Private Sub b_suiv_Click()
  If pointeur < Me.ListBox1.ListCount - 1 Then
    pointeur = pointeur + 1
    ligne = Me.ListBox1.List(pointeur, 1)
    affiche
  End If
End Sub

Private Sub b_prec_Click()
  If pointeur > 0 Then
    pointeur = pointeur - 1
    ligne = Me.ListBox1.List(pointeur, 1)
    affiche
  End If
End Sub

Private Sub b_premier_Click()
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub b_dernier_Click()
  pointeur = Me.ListBox1.ListCount - 1
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub B_ok_Click()
  Me.ListBox1.Clear
  i = 0
  Set plage = f.[A1].CurrentRegion
  Set c = plage.Find(Me.MotCle, , , xlPart)
  If Not c Is Nothing Then
    premier = c.Address
    Do
      Me.ListBox1.AddItem
      lig = c.Row
      Me.ListBox1.List(i, 0) = plage.Cells(lig, 1)
      Me.ListBox1.List(i, 1) = lig
      i = i + 1
      Set c = plage.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> premier
  End If
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub b_tout_Click()
  Me.ListBox1.Clear
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = i
  Next
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Sub affiche()
  For i = 1 To nbCol:
    Me("textbox" & i).Value = f.Cells(ligne, i)
    w = Evaluate("Cell(""format""," & f.Cells(ligne, i).Address & ")")
    If Left(w, 1) = "C" Then Me("textbox" & i).Value = Format(f.Cells(ligne, i), "0000.00 €")
  Next i
End Sub

Saisie de date début et date fin dans un tableau 2 colonnes

-Afficher le formulaire calendrier (double-clic)
-Cliquer sur la cellule dans la colonne Date début
-Choisir la Date début dans le calendrier
-Choisir Date Fin dans le calendrier
-Ok

Calendrier2Dates

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  F_calendrier2datesTableur.Show
  Cancel = True
End Sub

Le formulaire peut être exporté puis importé dans un autre classeur (clic-droit/exporter).

Le calendrier Microsoft :
-ne permet de choisir un intervalle de dates
-ne donne pas les jours fériés

Formulaire de saisie BD avec dates

FormSaisie2dates

Private Sub UserForm_Initialize()
  With Sheets("Listes")
    Me.Lieu.List = .Range("a2:A" & .Range("A65000").End(xlUp).Row).Value
    Me.Thème.List = .Range("b2:b" & .Range("b65000").End(xlUp).Row).Value
  End With
  F_calendrier2dates.Show
  F_calendrier2dates.Left = 190
  F_calendrier2dates.Top = 170
End Sub

Private Sub B_ok_dates_Click()
   Me.début = F_calendrier2dates.date_début
   Me.fin = F_calendrier2dates.date_fin
End Sub

Private Sub B_ok2_Click()
   If Me.Stage = "" Then
      MsgBox "Stage!"
      Me.Stage.SetFocus
      Exit Sub
  End If
  If Me.Lieu = "" Then
    MsgBox "Lieu!"
    Me.Lieu.SetFocus
    Exit Sub
  End If
  If Not IsDate(Me.début) Or Not IsDate(Me.fin) Then
     MsgBox "Dates!"
     Exit Sub
  End If
  With Sheets("BD")
    ligne = .Range("A65000").End(xlUp).Row + 1
    .Cells(ligne, 1) = Me.Stage
    .Cells(ligne, 2) = Me.Lieu
    .Cells(ligne, 3) = Me.Thème
    .Cells(ligne, 4) = CDate(Me.début)
    .Cells(ligne, 5) = CDate(Me.fin)
  End With
  Me.Stage = ""
  Me.Lieu = ""
  Me.Thème = ""
  Me.début = ""
  Me.fin = ""
End Sub

Private Sub B_fin_Click()
   Unload F_calendrier2dates
   Unload Me
End Sub

Liste des fichiers d'un répertoire dans un ListBox

Sur cet exemple, nous obtenons la liste des fichiers du répertoire du classeur où est situé le code.

FormListBoxFichiers

Private Sub UserForm_Initialize()
  repertoire = ThisWorkbook.Path & "\" ' adapter
  nf = Dir(repertoire & "*.*")   ' premier fichier
  Do While nf <> ""
    Me.ListBox1.AddItem nf
    nf = Dir                             ' fichier suivant
  Loop
End Sub

Choix de la colonne de tri dans un combobox

FormTri

Private Sub UserForm_Initialize()
  Me.ComboBox1.List = Application.Transpose([A1].CurrentRegion.Resize(1))
End Sub

Private Sub ComboBox1_Change()
  [A1].CurrentRegion.Sort Key1:=[A1].Offset(, Me.ComboBox1.ListIndex), Header:=xlGuess
End Sub

Private Sub Workbook_Open()
  UserForm1.Show
End Sub

Liste des feuilles d'un fichier

ListeFeuillesFichier

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

Private Sub ComboBox1_Change()
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  FichXLS = Me.ComboBox1
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & repertoire & FichXLS & ";Extended Properties=Excel 8.0;"
  Set cata.ActiveConnection = cnn
  Me.ListBox1.Clear
  For Each t In cata.Tables
     Me.ListBox1.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Facture

Facture

Dim ComboProd(1 To 5) As New ClasseProdFacture
Dim TextQte(1 To 5) As New ClasseQteFacture
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboProd(b).GrProduitFact = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQteFact = Me("qte" & b): Next b
  For i = 1 To 5
    'Me("produit" & i).List = TriChamp(Application.Index([BdProduit4], , 1))
    Me("produit" & i).List = TriChamp(Range([J2], [J2].End(xlDown)))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("libellé" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 2, False)
  Me("Prix" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 3, False)
  Calcul no
End Sub

Sub Calcul(no)
  If Me("Prix" & no) <> "" And Me("Qte" & no) <> "" Then
    Me("Total" & no) = CDbl(Me("Prix" & no)) * CDbl(Me("Qte" & no))
  End If
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("Libellé" & i)
    ActiveCell.Offset(0, 2) = Val(Me("Prix" & i))
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrProduitFact As MSForms.ComboBox
Private Sub GrProduitFact_Click()
  F_Facture.ChoixProduit Mid(GrProduitFact.Name, 8)
End Sub

Public WithEvents GrQteFact As MSForms.TextBox
Private Sub GrQteFact_change()
  F_Facture.Calcul Mid(GrQteFact.Name, 4)
End Sub

Devis multi lignes

DevisMultiLignes

Dim ComboCoul(1 To 5) As New ClasseCoul
Dim ComboProd(1 To 5) As New ClasseProd
Dim TextQte(1 To 5) As New ClasseQte
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboCoul(b).GrCouleur = Me("couleur" & b): Next b
  For b = 1 To 5: Set ComboProd(b).GrProduit = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQte = Me("qte" & b): Next b
  For i = 1 To 5
    Me("produit" & i).List = SansDoublonsTrié(Application.Index([BdProduit2], , 1))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("couleur" & no).Clear
  For Each c In Range([J2], [j65000].End(xlUp))
    If c = Me("produit" & no) Then Me("couleur" & no).AddItem c.Offset(0, 1)
  Next c
End Sub

Sub ChoixCouleur(no)
  For i = 1 To [BdProduit2].Rows.Count
     If Me("produit" & no) = [BdProduit2].Cells(i, 1) _
        And Me("couleur" & no) = [BdProduit2].Cells(i, 2) Then
          Me("total" & no) = [BdProduit2].Cells(i, 3) * Val(Me("qte" & no))
     End If
  Next i
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("couleur" & i)
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrCouleur As MSForms.ComboBox
Private Sub GrCouleur_Click()
  F_Devis.ChoixCouleur Mid(GrCouleur.Name, 8)
End Sub

Public WithEvents GrProduit As MSForms.ComboBox
Private Sub GrProduit_Click()
  F_Devis.ChoixProduit Mid(GrProduit.Name, 8)
End Sub

Public WithEvents GrQte As MSForms.TextBox
Private Sub GrQte_change()
  F_Devis.ChoixCouleur Mid(GrQte.Name, 4)
End Sub

Choix d'une feuille

On peut créer une nouvelle feuille.

Form choix Feuille2

Autres versions

Form choix Feuille1
Form Choix FeuilleTrie1
Form Choix FeuilleTrie2
FormFeuilleCondTrié

Private Sub UserForm_Initialize()
  For Each s In ActiveWorkbook.Sheets
    Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
   temp = Me.ComboBox1.Value
   On Error Resume Next
   Sheets(Me.ComboBox1.Value).Select
   If Err > 0 Then
     If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = temp
       Me.ComboBox1.AddItem temp
     End If
  End If
End Sub

Private Sub ComboBox1_Click()
   Sheets(Me.ComboBox1.Value).Select
End Sub

Liste triée des recettes en A1 du classeur en combobox

Les noms des recettes sont en A1.

ChoixFeuille

Private Sub UserForm_Initialize()
  Dim temp()
  For i = 2 To Sheets.Count
    Me.ComboBox1.AddItem
    Me.ComboBox1.List(i - 2, 0) = Sheets(i).[A1]
    Me.ComboBox1.List(i - 2, 1) = Sheets(i).Name
  Next i
  temp = Me.ComboBox1.List
  Call tri(temp(), LBound(temp, 1), UBound(temp, 1), 2, 0)
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
   m = Me.ComboBox1.Column(1)
   Sheets(m).Select
End Sub

Sub tri(a(), gauc, droi, NbCol, colTri) ' Quick sort
   ref = a((gauc + droi) \ 2, colTri)
   g = gauc: d = droi
   Do
     Do While a(g, colTri) < ref: g = g + 1: Loop
     Do While ref < a(d, colTri): d = d - 1: Loop
     If g <= d Then
       For c = 0 To NbCol - 1
         temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
       Next
       g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi, NbCol, colTri)
   If gauc < d Then Call tri(a, gauc, d, NbCol, colTri)
End Sub

ListBox en couleur

ListBoxSimuleClasse
ListBoxSimuleSansClasse

Dim début, n
Dim Lbl(1 To 5) As New ClasseLabel
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set Lbl(b).GrLabel = Me("Label" & b): Next b
    début = 1
    n = 5
    Me.ScrollBar1.Min = 1
    Me.ScrollBar1.Max = [liste].Count - n + 1
    affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
    Me("label" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1).Offset(, 1)
    Me("label" & i).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
    Me("label" & i).ForeColor = Range("liste").Cells(i + début - 1, 1).Font.Color
  Next i
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Module de classe ClasseLabel

Public WithEvents GrLabel As Msforms.Label
Private Sub GrLabel_click()
  p = Val(Mid(GrLabel.Name, 6))
  For i = 1 To 5: UserForm1.Controls("label" & i).BorderStyle = 0: Next i
  UserForm1.Controls("label" & p).BorderStyle = 1
  For Each c In Selection
    c.Value = GrLabel.Caption
    c.Font.Color = GrLabel.ForeColor
    c.Interior.Color = GrLabel.BackColor
  Next
End Sub

ListBox photo

Les photos d'origine sont dans des commentaires

ListBoxPhotoInterneCommentaire

Ce programme exporte les photos en commentaire sous forme de JPG dans un répertoire c:\photos\

Sub auto_open()
  répertoirePhotos = "c:\photos\"    ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    c.Comment.Visible = True
    H = c.Comment.Shape.Height
    L = c.Comment.Shape.Width
    c.Comment.Shape.CopyPicture
    c.Comment.Visible = False
    f.ChartObjects.Add(0, 0, L, H).Chart.Paste
    f.ChartObjects(1).Border.LineStyle = 0
    f.ChartObjects(1).Chart.Export Filename:= _
       répertoirePhotos & c & ".jpg", FilterName:="jpg"
    f.ChartObjects(1).Delete
  Next c
  UserForm1.Show
End Sub

Code du formulaire

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhotos
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [Liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhotos = "c:\photos\" ' Adapter
  For i = 1 To n
     nom = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).Picture = LoadPicture(répertoirePhotos & Range("liste").Cells(i + début - 1, 1) & ".jpg")
     Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).BorderStyle = 0
     Me("Label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Sub ChoixClick(p, nom)
   For i = 1 To n
     Me("Image" & i).BorderStyle = 0
   Next i
   Me("Image" & p).BorderStyle = 1
   Set sel = Selection
   For Each c In Selection
     c.Value = nom
     Liste].Find(c.Value, LookAt:=xlWhole).Copy
     c.PasteSpecial Paste:=xlPasteFormats
     c.PasteSpecial Paste:=xlPasteComments
   Next c
   sel.Select
End Sub

Private Sub Image1_Click()
  ChoixClick 1, Me.Image1.ControlTipText
End Sub

Private Sub Image2_Click()
  ChoixClick 2, Me.Image2.ControlTipText
End Sub

Private Sub Image3_Click()
   ChoixClick 3, Me.Image3.ControlTipText
End Sub

Private Sub Label1_Click()
  ChoixClick 1, Me.Label1.Caption
End Sub

Private Sub Label2_Click()
ChoixClick 2, Me.Label2.Caption
End Sub

Private Sub Label3_Click()
ChoixClick 3, Me.Label3.Caption
End Sub

Les photos sont externes

ListBoxPhotoExterne

Les photos sont internes au classeur, encapsulées dans des images BO contrôles

ListBoxPhotoInterne

Renommer un fichier

RenommerFichier

Private Sub UserForm_Initialize()
  Me.Dossier = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir("*.*") ' premier
  Do While nf <> ""
     Me.ChoixFichier.AddItem nf
     nf = Dir ' suivant
  Loop
End Sub

Private Sub ChoixFichier_Click()
   Me.FichierChoisi = Me.ChoixFichier
End Sub

Private Sub B_ok_Click()
   On Error Resume Next
   Name ChoixFichier As Me.FichierChoisi
   UserForm_Initialize
End Sub

Private Sub b_dossier_Click()
   DossierChoisi = VoirDossier("Choisir le dossier")
   If DossierChoisi <> "" Then
       Me.Dossier = DossierChoisi
       ChDir DossierChoisi
   End If
   UserForm_Initialize
End Sub

Message défilant

Message défilant

Private Sub UserForm_Initialize()
Me.Label1.Caption = "Le message qui défile pendant un temps donné ..."
End Sub

Private Sub UserForm_Activate()
  n = Len(Me.Label1.Caption) * 2
  For i = 1 To n
    Me.Label1.Caption = Right(Me.Label1.Caption, Len(Me.Label1.Caption) - 1) & Left(Me.Label1.Caption, 1)
    w = 0.2
    temp = Timer
     Do While Timer < temp + w
       DoEvents
    Loop
  Next i
End Sub

Message défilant2

Dim depart, lg
Private Sub UserForm_Initialize()
  Me.Label1.Width = 700
  depart = Me.Label1.Left
  Message = "Ceci est un message défilant..."
  Me.Label1.Caption = Message & Message & Message
  lg = Len(Me.Label1.Caption)
End Sub

Private Sub UserForm_Activate()
  Me.Label1.Visible = True
  For x = depart To -(4.16 * lg - depart) Step -1
    Me.Label1.Left = x
    Me.Label1.Top = 10
    w = 0.04
    temp = Timer
    Do While Timer < temp + w
     DoEvents
    Loop
  Next x
  UserForm_Activate
End Sub

Barre d'attente

F_BarreAttente

Sub Attente()
  n = 20 ' nb de fichiers à traiter
  témoin = True ' pour empêcher fermeture du formulaire
  F_BarreAttente.Show False
  For f = 1 To n
    '-- traitement fichier
    For a = 1 To 50000000: Next a ' Simulation attente
      '--------------
      p = p + 1 / n ' calcul du pourcentage
      F_BarreAttente.Label1.Width = p * 100
      F_BarreAttente.Caption = Format(p, "0%")
      DoEvents
    Next f
    témoin = False
    Unload F_BarreAttente
End Sub

Pour empêcher la fermeture du formulaire

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If témoin Then Cancel = True
End Sub

Autre exemple

BarreProgression

On dit ouvrir tous les fichiers commençant par A. On suppose que le temps de chargement de chaque fichier est proportionnel à la taille. On calcule d'abord la longueur totale des fichiers à traiter.

Private Sub UserForm_Activate()
  Deroule
End Sub

Private Sub Deroule()
  Application.DisplayAlerts = False
  ChDir (ActiveWorkbook.Path)
  masque = "a*.xls"
  nf = Dir(masque)
  '- taille totale
  n = 0
  Do While nf <> ""
    n = n + FileLen(CurDir() & "\" & nf)
    nf = Dir()
  Loop
  '----
  Application.StatusBar = "Attendez Svp..." & c
  nf = Dir(masque)
  Do While nf <> ""
    Workbooks.Open Filename:=nf
    ActiveWorkbook.Close
    p = p + FileLen(CurDir() & "\" & nf) / n
    UserForm1.CadreProgression.Caption = Format(p, "0%")
    UserForm1.BarreProgression.Width = p * (UserForm1.CadreProgression.Width - 15)
    UserForm1.Repaint
    nf = Dir()
   Loop
   Unload Me
   Application.StatusBar = ""
End Sub

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Création de boutons

FormCrétionBoutons


Private Sub B_crée_Click()
  For b = 1 To Me.Combien
    retour = Me.Controls.Add("Forms.OptionButton.1", "Opt" & b, True)
    Me("Opt" & b).Top = 40
    Me("Opt" & b).Left = 30 + (b - 1) * 15
  Next
End Sub

Private Sub B_sup_Click()
   For b = 1 To Me.Combien
     On Error Resume Next
     Me.Controls.Remove "opt" & b
  Next
End Sub

Private Sub b_result_Click()
   For b = 1 To Me.Combien
     On Error Resume Next
     If Me("opt" & b) Then MsgBox b
   Next
End Sub

Private Sub B_label_Click()
   retour = Me.Controls.Add("Forms.Label.1", "Label1", True)
   Me("label1").Caption = "essai"
   Me("label1").Top = 60
   Me("label1").Left = 200
End Sub

Private Sub b_sup_label_Click()
  Me.Controls.Remove "Label1"
End Sub

Simulation listBox couleur

-Permet d'obtenir une ligne sur 2 en couleur
-Permet d'afficher du texte sur plusieurs lignes

ListBoxSimul
ListBoxFiltreElaboré
ListBoxFiltreElaboré6Col

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, nLigneTxt, n, f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  début = 1
  nLigneTxt = 5
  n = nLigneTxt
  nBD = Application.CountA(f.[A:A]) - 1
  If nBD < n Then n = nBD
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = nBD - n + 1
  affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("txt1" & i).Value = f.Cells(i + début, 1)
    Me("txt2" & i).Value = f.Cells(i + début, 2)
    Me("txt3" & i).Value = f.Cells(i + début, 3)
    If i Mod 2 = 0 Then
      Me("txt1" & i).BackColor = RGB(0, 255, 0)
      Me("txt2" & i).BackColor = RGB(0, 255, 0)
      Me("txt3" & i).BackColor = RGB(0, 255, 0)
    End If
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
   début = ScrollBar1
   affiche
End Sub

Private Sub B_ok_Click()
  Set f = Sheets("BD")
  f.[K2] = "*" & Me.TextBox1 & "*"
  f.[A1:C10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[K1:K2],      CopyToRange:=Sheets("interro").[A1:C1]
  Set f = Sheets("interro")
  début = 1
  For i = 1 To n
    Me("txt1" & i).Value = ""
    Me("txt2" & i).Value = ""
    Me("txt3" & i).Value = ""
  Next i
  nInterro = Application.CountA(f.[A:A]) - 1
  If nInterro < n Then n = nInterro
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = nInterro - n + 1
  affiche
  n = nLigneTxt
End Sub

Simulation Listbox avec image arrière-plan

ListBoxImageFond

Editeur de cellule

-Les ajouts sont mis dans la couleur du nom d'utilisateur
-Double-cliquer sur la cellule à modifier

EditCellule

Dim couleur As String, CouleurUser As Integer
  Private Sub UserForm_Initialize()
  CouleurUser = 4
  p = Application.Match(Environ("username"), [utilisateurs], 0)
  If Not IsError(p) Then CouleurUser = Range("couleurs")(p)
  Me.TextBox1 = ActiveCell
  n = Len(Me.TextBox1)
  For i = 1 To n
    c = ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex
    If c = -4105 Then c = 255
    couleur = couleur & Chr(c)
  Next i
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  lg = TextBox1.SelLength
  If lg = 0 Then lg = 1
  If KeyCode = 46 Then ' Touche sup
    p = TextBox1.SelStart
    couleur = Left(couleur, p) & Mid(couleur, p + lg + 1)
  Else
    If KeyCode = 8 Then ' Touche backspace
       p = TextBox1.SelStart
       couleur = Left(couleur, p - 1) & Mid(couleur, p + lg)
     Else
       If KeyCode <> 37 And KeyCode <> 39 And KeyCode <> 16 Then ' 16
         p = TextBox1.SelStart
         couleur = Left(couleur, p) & Chr(CouleurUser) & Mid(couleur, p + 1)
       End If
     End If
   End If
End Sub

Private Sub B_ok_Click()
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveCell = Replace(Me.TextBox1, Chr(13), "")
  n = Len(ActiveCell)
  For i = 1 To n
    c = Asc(Mid(couleur, i, 1))
    If c = 255 Then c = -4105
    ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex = c
  Next i
  Unload Me
End Sub

Recherche un mot dans tout le classeur

RechercheMotClasseur

Recherche d'un mot dans une colonne de BD

Recherche Mot ComboBox
Recherche Mot TextBox
Recherche Mot Formulaire

Private Sub ComboBox1_Click()
  Set fRech = Sheets("recherche")
  Set fbd = Sheets("bd")
  fRech.[J2] = "*" & Me.ComboBox1 & "*"
  fbd.Range("A1:F10000").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=fRech.Range("J1:J2"), CopyToRange:=fRech.Range("A1:F1")
End Sub

Recherche adhérent

La recherche se fait avec

-les premières lettres de la première colonne (ou de toutes les colonnes)
-lettres contenues dans la première colonne (ou de toutes les colonnes)

Le résultat est affiché dès la saisie des caractères.

Recherche Adhérent Find

Private Sub TextBox1_Change()
  Set fRech = Sheets("recherche")
  Set fbd = Sheets("bd")
  Set plageBD = fbd.[a1].CurrentRegion.Offset(1)
  ncol = plageBD.Columns.Count
  Application.ScreenUpdating = False
  fRech.[A11].Resize(100, ncol + 1).ClearContents
  Set plageRech = IIf(Me.CheckBox1, plageBD, Range(fbd.[A2], fbd.[A65000].End(xlUp)))
  Set c = plageRech.Find(Me.TextBox1 & "*", , , xlWhole)
  LigRech = 1
  If Not c Is Nothing Then
    premier = c.Address
    Do
      ligBD = c.Row - plageBD.Row + 1
      For col = 1 To ncol
        fRech.[A11].Cells(LigRech, col) = plageBD.Cells(ligBD, col)
      Next col
      fRech.[A11].Cells(LigRech, ncol + 1) = ligBD
      Set c = plageRech.FindNext(c)
      LigRech = LigRech + 1: If LigRech > 100 Then Exit Do
    Loop While Not c Is Nothing And c.Address <> premier
  End If
End Sub

Accès rapide

Accès Rapide

Private Sub ComboBox1_Click()
  p = Application.Match(CDbl(CDate(Me.ComboBox1)), [a:a], 0)
  If Not IsError(p) Then [a1].Offset(p - 1).Select
End Sub

Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
For Each c In [A3:A1000]
   If c <> "" Then Me.ComboBox1.AddItem c
Next
End Sub

Message défilant dans un label de formulaire

FormDéfilant

Dim depart, lg
Private Sub UserForm_Initialize()
  Me.Label1.Width = 700
  depart = Me.Label1.Left
  Message = "Ceci est un message défilant..."
  Me.Label1.Caption = Message & Message & Message
  lg = Len(Me.Label1.Caption)
End Sub

Private Sub UserForm_Activate()
  Me.Label1.Visible = True
  For x = depart To -(4.16 * lg - depart) Step -1
    Me.Label1.Left = x
    Me.Label1.Top = 10
    w = 0.04
    temp = Timer
    Do While Timer < temp + w
      DoEvents
    Loop
  Next x
  UserForm_Activate
End Sub

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Private Sub UserForm_Initialize()
  Me.Répertoire = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir(Me.Répertoire & "\*.*") ' premier
  n = 0
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir ' suivant
    n = n + 1
  Loop
  Me.nbFichiers = n
End Sub

Private Sub ChoixFichier_Click()
  Me.FichierChoisi = Me.ChoixFichier
End Sub

Private Sub B_ok_Click()
   On Error Resume Next
   Name ChoixFichier As Me.FichierChoisi
  UserForm_Initialize
End Sub

Private Sub b_dossier_Click()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = CurDir()
      .Show
      If .SelectedItems.Count > 0 Then
        Me.Répertoire = .SelectedItems(1)
        ChDir Me.Répertoire
      Else
        Me.Répertoire = ""
      End If
      UserForm_Initialize
    End With
  Else
     DossierChoisi = VoirDossier("Choisir le dossier")
     If DossierChoisi <> "" Then
       Me.Répertoire = DossierChoisi
       ChDir DossierChoisi
   End If
   UserForm_Initialize
  End If
End Sub

Visualisation d'un fichier texte

VisuTxt

Private Sub UserForm_Initialize()
  Me.Dossier = CurDir()
  Me.ChoixFichier.Clear
  Me.Texte = ""
  nf = Dir("*.txt") ' premier
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir ' suivant
  Loop
End Sub

Private Sub ChoixFichier_Click()
  Open Me.ChoixFichier For Input As #1
  MonTexte = ""
  Do While Not EOF(1)
     Line Input #1, ligne
     MonTexte = MonTexte & ligne & Chr(13)
  Loop
  Close #1
  Me.Texte = MonTexte
End Sub

Simulation ListBox couleur

ListBoxSimuleClasse
ListBoxSimuleClasseSansClasse

Dim début, n
Private Sub UserForm_Initialize()
  début = 1
  n = 5
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
    Me("label" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1).Offset(, 1)
    Me("label" & i).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
    Me("label" & i).ForeColor = Range("liste").Cells(i + début - 1, 1).Font.Color
  Next i
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Private Sub Label1_Click()
  p = 1
  ChoixClick p
End Sub

Saisie de numéro de téléphone avec masque de saisie

-Cliquer dans la cellule
-Saisir le no de tph
-Valider avec la touche Entrée

On peut utiliser les flèches et la touche Suppr

Form Saisie Téléphone Tableur
Form Saisie Téléphone
Form Saisie Code Postal

 

 

 

 





 

 

 

Exemples

Formulaire création simple
Formulaire création
Formulaire consultation
Formulaire modification
Formulaire Modif/Création
Formulaire Suivant/Précédent
Choix lettre
Choix lettre2
Choix lettre5
Formulaire Synthèse
Form Liste Onglets
Saisie heures
Form Cascade Find
Form Cascade Trié
Form Cascade Pays
Form cascade client facture
Import Txt
Form Impression
Form Questionnaire
Form Liste ajout
Form cascade Pays Villes
Form Liste Fusion
Form Recherche ET
Form RechercheClasseur
Form CheckBox
Form Attente
Form Clignote
Form Barre Progression
Form ListBox sans doublons
Form cascade codes postaux
Form affichage
Form cascade image
Form cascade image3
Feuille combo sans doublons
Form Photo
FormPhotoInterne
Form Heure
Form Chrono
Survol Texte Formulaire
Choix Fichier
Form ListBox Titre Colonne
Form Choix Feuille
Form Choix Feuille1

Form Choix FeuilleTrie1
Form Choix FeuilleTrie2
Form Choix Feuille2
Form Choix Feuille3
FormFeuilleCondTrié
Form Champs Indices
Form Hyper-Lien
FormGénérique
FormListeFichiers
ChercheMot
FormEquivIndex

Calendriers

CalendrierTableur1date
CalendrierTableaur2dates
Calendrier Form1 date
Calendrier Form2 dates
Calendrier Microsoft Tableur
Calendrier Microsoft Form

BO Contrôle-Formulaire

BO controles
BO Fomulaire
BO controles Indices
BO Controles ListBox Trié
BO Controles Cascade
BO Controle Choix Feuille