Accueil

 

Evénements du classeur WorkBook_Open WorkBook_Before_Save WorkBook_Before_Close WorkBook_Before_Print WorkBookSheetActivate Evénements des feuilles WorkSheet_Change WorkSheet_Selection_Change WorkSheet_BeforeDouble_Click Evénement OnTime,Timer,Wait OnTime Timer Wait OnKey MouseMove Evénement Calculate

-Modifie l'entête d'impression -Protection onglet -Mémorisation nom utilisateur -Modifie en-tête d'impression -Interdit impression si erreur -Impression par macro obligatoire -Traduction en majuscules -Supprime les doubles espaces -Caractères numériques en rouge -Heure de saisie en commentaire -Saisie ordre lignes -Doublons interdits -Couleur fonction du mot saisi -Calcul dynamique -Protection dynamique -Extraction dynamique -Choix de la colonne de tri -Nom utilisateur réseau mémorisé -Tri dynamique -Positionne la ligne active haut écran -Modifie contenu cellule sur double clic -Affiche heure -Fermeture après temps inactivité -Clignotement cellule -Survol image/texte/bouton -Zoom d'un champ au survol du champ -Affichage d'un champ au survol d'une image -Image au survol d'une cellule -Inversion d'image au survol -Modifie couleur d'une cellule au survol -Survol d'une cellule d'un champ -Visualisation cellule dans un shape au survol -Visualisation d'une cellule dans un formulaire au survol -Affiche une bulle d'aide dans un champ -Modifie texte en fonction de la couleur -Commentaire dynamique -Modification de la police -Interdit suppression/modification -Saisie Multi Cellules -Mémorise l'historique des modifications -Editeur de cellule -Coloriage des modifs de saisie

WorkBook_Open() Before Save Before Close WorkSheet_Change() EnableEvents Selection_Change() Double_Click() Before_Print() Timer OnTime Wait OnKey MouseMove Application.Undo SendKeys

Evénements du classeur

Workbook_Open()

Cet événement est activé à l’ouverture du classeur.

Chaque utilisateur ne voit que l’onglet qui le concerne

A la sauvegarde du classeur, on masque toutes les feuilles. A l'ouverture du classeur, on affiche
seulement celle de l'utilisateur

ProtectionOngletSimple

Private Sub Workbook_Open()
  On Error Resume Next
  Sheets(Environ("username")).Visible = True
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   For s = 2 To Sheets.Count ' on masque les feuilles
     Sheets(s).Visible = xlVeryHidden
   Next s
End Sub

Une macro auto_open() dans un module du classeur est également exécutée à l'ouverture du classeur.
En appuyant sur la touche Maj, on empêche l'exécution de auto_open().
Elle n'est pas exécutée si le classeur est ouvert par VBA.

Crée une liste perso sur le poste de l’utilisateur à l’ouverture du classeur

Sub auto_open()
  Application.AddCustomList _
  ListArray:=Array("France", "Italie", "Espagne", "Grèce", "Allemagne", "Potugal")
End Sub

Workbook_BeforeSave()

Cet événement est declenché avant la sauvegarde du classeur. Le paramètre Cancel=True
permet d'annuler l'événement.

Enregistre le nom du dernier utilisateur dans l'onglet Dernier_utilisateur

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Sheets("dernier_utilisateur").Range("a1") = Environ("username")
  Sheets("dernier_utilisateur").Range("a2") = Now
End Sub

Sur cette version, on mémorise plusieurs utilisateurs.

-EnregistreNomUtilisateur -

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  p = Application.Match(Environ("username"), Sheets("DernierUtilisateur").Range("A:A"), 0)
  If Not IsError(p) Then
    Sheets("DernierUtilisateur").Cells(p, 2) = Now ' l'utilisateur existe déjà
  Else
    p = Sheets("DernierUtilisateur").[A65000].End(xlUp).Row + 1
    Sheets("DernierUtilisateur").Cells(p, 1) = Environ("username")
    Sheets("DernierUtilisateur").Cells(p, 2) = Now
  End If
End Sub

Interdit la sauvegarde si la cellule A1 n’est pas saisie

On ne peut pas sauvegarder si A1 est vide

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   If [A1] = "x" Then
      [A1] = ""
   Else
      If [A1] = "" Then
        MsgBox "La Cellule A1 n'est pas saisie"
        Cancel = True
      End If
   End If
End Sub

Workbook_BeforeClose()

Cet evénement est déclenché à la fermeture du classeur. Le paramètre Cancel=True permet
d'annuler l'évenement .

Vérifie à la fermeture si A1 est documenté.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   If IsEmpty([A1]) Then
     If MsgBox("A1 pas documenté voulez vous quitter? ", vbYesNo) <> vbYes Then
       Cancel = True
      [A1].Select
      Exit Sub
    End If
  End If
End Sub

A la fermeture du classeur, le message 'Voulez vous sauvegarder? ' est affiché seulement s'il y a eu modif

Lorsqu'un fonction personalisée est présente dans un classeur, le message 'Voulez vous sauvegarder?' est affiché à la fermeture du classeur, même s'il n'y a pas eu de modification. Pour supprimer ce message:

BeforeClose

Dans un module

Public TemoinModif As Boolean
Function DernièreSauvegarde()
  Application.Volatile
  DernièreSauvegarde = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function

Dans ThisworkBook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  If Not TemoinModif Then
     ActiveWorkbook.Saved = True
  End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   TemoinModif = True
End Sub

Workbook_BeforePrint()

Cet événement est déclenché à l'impression. le paramètre Cancel=True permet d'annuler l'impression.

Modifie l'entête avec le contenu de la cellule A1

Private Sub Workbook_BeforePrint(Cancel As Boolean)
   If ActiveSheet.Name = "Feuil1" Then
     ActiveSheet.PageSetup.CenterHeader = Sheets("Feuil1").Range("A1")
   End If
End Sub

Interdit l'impression s'il y a une erreur dans la feuille

Une feuille ne peut pas être imprimée s'il y a une erreur dans la feuille.

- ImpressionInterditSiErreur -

Dans ThisWorkBook.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  On Error Resume Next
  Cells.SpecialCells(xlCellTypeFormulas, 16).Select
  If Err = 0 Then
    MsgBox "Il y a une erreur!"
    Cancel = True
  End If
End Sub

L'impression doit se faire par macro

L'utilisateur ne peut pas imprimer directement.

- ImpressionDirecteInterdite -.

Dans un module:

Public impressionAutorisée
Sub Imprime()
  Range("A1:B4").Select
  ActiveSheet.PageSetup.PrintArea = "$A$1:$B$4"
  impressionAutorisée = True
  ActiveWindow.SelectedSheets.PrintPreview
  impressionAutorisée = False
End Sub

Dans ThisWorkBook:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  If Not impressionAutorisée Then
     MsgBox "Non!"
     Cancel = Not impressionAutorisée
  End If
End Sub

Workbook_SheetActivate

Cet événement est activé à chaque fois q'une feuille est activée.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
  If Sh.Index >= 3 And Sh.Index <= 5 Then
     MsgBox Sh.Name
  End If
End Sub

Onglet en couleur si modification

Les onglets sont coloriés en jaune si visités.
Les onglets sont coloriés en rouge si modifiés.

OngletCouleur

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
   If Sh.Tab.ColorIndex <> 3 Then Sh.Tab.ColorIndex = 6
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Sh.Tab.ColorIndex = 3
End Sub

Dernier onglet visité

Crée un hyper-lien dans le premier onglet, vers le dernier onglet visité.

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
   Sheets(1).Hyperlinks.Add Anchor:=Sheets(1).[A2], Address:="", SubAddress:="'" & Sh.Name & "'" & "!A1",       TextToDisplay:="Dernière visite:" & Sh.Name
End Sub

Evénements des feuilles

Worksheet_Change()

Le code VBA de la procédure Sub Worksheet_Change() est exécuté à chaque fois qu'une
cellule est modifiée dans une feuille, que ce soit directement par la saisie de l'opérateur
ou par programme.

Application.EnableEvents =True/false

Afin d'éviter le déclenchement d'événements intempestifs lorsque le programme modifie le
contenu de cellules, on utilise Application.EnableEvents =False pour désactiver la gestion
des événements.
On la réactive lorsque le traitement est termiiné.
En cours de mise au point, si le programme est stoppé avant la réactivation des événements,
il faut quitter Excel et l'ouvrir à nouveau pour que la gestion des événements soit à nouveau active.

Traduit en Nompropre dès la saisie dans la colonne A

NomPropre

• Clic-droit sur l'onglet puis visualiser le code
• Choisir WorkSheet dans menu déroulant
• Choisir événement Change dans menu déroulant

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.EnableEvents = False
  If Target.Column = 1 And Target.Count = 1 Then
     Target = Application.Proper(Target)
  End If
  Application.EnableEvents = True
End Sub

Supprime les doubles espaces à la saisie

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count = 1 Then
    Application.EnableEvents = False
    Target = Application.Trim(Target)
    Application.EnableEvents = True
  End If
End Sub

Complète la saisie par des 0 à gauche

01517
01521
01543
01578

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    If Target <> "" And Len(Target) < 5 Then
      Application.EnableEvents = False
      Target.NumberFormat = "@"
      Target = String(5 - Len(Target), "0") & Target
      Application.EnableEvents = True
    End If
  End If
End Sub

Saisie d'une heure avec ou sans le caractère :

0915 --> 09:15
915 --> 09:15
9:15 --> 09:15
1730 --> 17:30

SaisieHeureSans2Points

Colorie en rouge les caractères numériques dans la colonne A

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Column And Target.Count = 1 Then
      Application.EnableEvents = False
      For i = 1 To Len(Target)
        If Mid(Target, i, 1) >= "0" And Mid(Target, i, 1) <= "9" Then
          Target.Characters(Start:=i, Length:=1).Font.ColorIndex = 3
        End If
      Next i
    Application.EnableEvents = True
   End If
End Sub

Colorie en rouge une partie de texte

Colorie Texte

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:A2], Target) Is Nothing And Target.Count = 1 Then
    lib = Application.VLookup(Target, [MaTable], 2, False)
    If Not IsError(lib) Then
      Target.Offset(, 1) = "Libellé:" & lib & " xxx"
      Target.Offset(, 1).Characters(Start:=9, Length:=Len(lib)).Font.ColorIndex = 3
      Target.Offset(, 1).Characters(Start:=9, Length:=Len(lib)).Font.Bold = True
    End If
  End If
End Sub

Met l'heure de saisie en commentaire

Date saisie

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 1 Then
    If Target.Comment Is Nothing Then Target.AddComment
    Target.Comment.Text Text:=CStr(Now)
    Target.Comment.Shape.TextFrame.AutoSize = True
    Target.Comment.Visible = False
  End If
End Sub

Saisie dans l'ordre des lignes

SaisieGuidée
Saisie Guidée Cellules
Saisie Guidée cellules Couleur
Saisie Guidée cellules Couleur MFC

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("B2:B10", "D2:D10"), Target) Is Nothing And Target.Count = 1 Then
     If Target.Column = 2 Then Cells(Target.Row, 4).Select
     If Target.Column = 4 Then Cells(Target.Row + 1, 2).Select
  End If
End Sub

Saisie anti-doublons dans la colonne A

L'ancienne valeur est restituée si doublon

Saisie anti-doublons

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
     Application.EnableEvents = False
     ValSaisie = Target
     Application.Undo
     temp = Application.Match(ValSaisie, [A2:A10000], 0)
     If Not IsError(temp) Then
        MsgBox "Doublon"
     Else
        Target = ValSaisie
     End If
     Application.EnableEvents = True
   End If
End Sub

On avertit si saisie d'un doublon dans un champ

Le champ de saisie (A1:A20) est nommé Monchamp.

Doublons Saisie
Doublons Saisie 2
Doublons Saisie nom prénom

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([monchamp], Target) Is Nothing And Target.Count = 1 Then
     valsaisie = Target
     Application.EnableEvents = False
     Application.Undo
     Set c = [monchamp].Find(valsaisie)
     If Not c Is Nothing Then
       If MsgBox(valsaisie & ":" & "Doublon en :" & c.Address & Chr$(10) & _
         "Voulez-vous le garder ?", vbYesNo + vbInformation, "Détection DOUBLON") = vbYes Then
         Target = valsaisie
       End If
     Else
       Target = valsaisie
       Target.Offset(1).Select
    End If
    Application.EnableEvents = True
  End If
End Sub

MFC en A1:A20
=NB.SI(monChamp;A1)>1

Pour interdire la saisie de doublons

-Sélectionner A2:A20
-Données/Validation/Perso
=NB.SI($A$1:$A$20;A1)=1

Interdit la saisie de doublons sur 3 colonnes

Doublons 3 colonnes

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim L, ligSaisie, adrSaisie
  If Target.Column >= 1 And Target.Column <= 3 And Target.Row > 2 And Target.Count = 1 Then
    ligSaisie = Target.Row
    For L = 2 To Application.CountA([A:A])
      If Cells(L, 1) = Cells(ligSaisie, 1) And Cells(L, 2) = Cells(ligSaisie, 2) _
         And Cells(L, 3) = Cells(ligSaisie, 3) And L <> ligSaisie Then
         MsgBox "Doublon avec ligne " & L
         Application.EnableEvents = False
         Application.Undo
        ' Cells(ligSaisie,1).Resize(, 3).ClearContents ' Efface la ligne
         Application.EnableEvents = True
      End If
    Next L
  End If
End Sub

Avec Données/Validation

=SOMMEPROD(($A$2:$A$19=$A2)*($B$2:$B$19=$B2)*($C$2:$C$19=$C2))<2

Modification de la couleur en fonction du mot saisi

La couleur de la cellule est modifiée à la saisie d'un mot.

ColoriageMot

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([B2:D15], Target) Is Nothing And Target.Count = 1 Then
    Target.Interior.ColorIndex = Range("couleurs").Find(Target).Interior.ColorIndex
  End If
End Sub

Calcul dynamique sans formule avec VBA

• On peut saisir la date en colonne C
• On peut saisir le nb de jours en colonne D

CalculDynamique
CalculDynamiqueMarge

Private Sub Worksheet_Change(ByVal Target As Range)
   Application.EnableEvents = False
   If Not Intersect([c2:c13], Target) Is Nothing And Target.Count = 1 Then
      Target.Offset(0, 1) = Target.Offset(0) - Target.Offset(0, -1) + 1
   End If
   If Not Intersect([d2:d13], Target) Is Nothing And Target.Count = 1 Then
      Target.Offset(0, -1) = Target.Offset(0, -2) + Target - 1
   End If
   Application.EnableEvents = True
End Sub

Autre exemple

Lorsque des formules sont recopiées sur plusieurs milliers de ligne, le temps de recalcul
peut devenir important.
Sur l'exemple, on affiche directement le résultat qui dépend des valeurs saisies en colonne A et B.

Private Sub Worksheet_Change(ByVal Target As Range)
   If (Target.Column = 1 Or Target.Column = 2) And Target.Count = 1 Then
       Application.EnableEvents = False
       temp = [tbl]
       x = Cells(Target.Row, 1)
       y = Cells(Target.Row, 2)
       Cells(Target.Row, 3) = 0
       For i = 1 To UBound(temp)
          If x = temp(i, 1) And y = temp(i, 2) Then
             Cells(Target.Row, 3) = temp(i, 3)
         End If
      Next i
      Application.EnableEvents = True
   End If
End Sub

Protection du contenu d'une colonne sans protection de la feuille

Dans la colonne 2, on ne peut pas modifier le contenu mais seulement les commentaires.

ProtectionContenu

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 2 Then
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
  End If
End Sub

Protection dynamique

Après la saisie dans une cellule du champ B2:B13, la cellule est verrouillée automatiquement.

ProtectionDynamique

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([B2:B13], Target) Is Nothing And Target.Count = 1 Then
     ActiveSheet.Unprotect Password:=""
     Target.Locked = True
     Target.Interior.ColorIndex = 44
     ActiveSheet.Protect Password:=""
   End If
End Sub

Saisie d'une liste dans une cellule

Chaque élément saisi en A2 est ajouté à la liste de la colonne A

SaisieListe

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
    n = Application.CountA([A3:A10000])
    Cells(3 + n, "a") = Target
    Target.Select
  End If
End Sub

Extrait les factures réglées dans un autre onglet

Lorsque l'opérateur sélectionne l'onglet Réglés, , les factures réglées sont extraites dans l’onglet.

FacturesRéglées

Private Sub Worksheet_Activate()
  Sheets("BD").[A1:D1000].AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=[G1:G2], CopyToRange:=[A1:D1]
End Sub

Choix de la colonne de tri dans une liste

TriMenu

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$G$2" And Target.Count = 1 Then
     col = Application.Match(Target, [A1:D1], 0) - 1
     Range("A2:D30").Sort Key1:=[A1].Offset(0, col)
   End If
End Sub

Place le nom (réseau) de l'opérateur de saisie dans la colonne D

NomDate

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:A65000], Target) Is Nothing And Target.Count = 1 Then
      Application.EnableEvents = False
      Cells(Target.Row, 4) = Environ("username")
      Cells(Target.Row, 5) = Now
      Application.EnableEvents = True
   End If
End Sub

Tri Dynamique

Le tri par nom est effectué à chaque saisie d'une ligne

TriDyn
TriDyn2

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    nom = Target
    [A2:C1000].Sort key1:=[A2]
    [A:A].Find(what:=nom).Select
  End If
End Sub

Modification de la police de caractères

On ajoute une flèche au nom à la saisie.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column <= 3 And Target <> "" And Target.Count = 1 Then
    Application.EnableEvents = False
    Select Case Cells(Target.Row, 2) - Cells(Target.Row, 3)
      Case Is > 0
        x = "ä"
      Case Is < 0
        x = "æ"
      Case Else
        x = "à"
    End Select
    c = Cells(Target.Row, 1)
    If Asc(Right(c, 1)) > 200 Then
       Cells(Target.Row, 1) = Left(c, Len(c) - 2) & " " & x
       Cells(Target.Row, 1).Characters(Start:=Len(c) - 1, Length:=2).Font.Name = "Wingdings"
    Else
       Cells(Target.Row, 1) = c & " " & x
       Cells(Target.Row, 1).Characters(Start:=Len(Cells(Target.Row, 1)) - 1, Length:=2).Font.Name = "Wingdings"
    End If
    Application.EnableEvents = True
  End If
End Sub

Autorise la saisie mais interdit la suppression dans un champ

La feuille n'est pas protégée.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A1:A10], Target) Is Nothing Then
    If Target(1) = "" Then
      Application.EnableEvents = False
      Application.Undo
      Application.EnableEvents = True
    End If
  End If
End Sub

Autorise la saisie mais interdit la suppression ou la modification dans un champ

La feuille n'est pas protégée.

UnduSupModif

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:A10], Target) Is Nothing Then
    If Target.Count > 1 Or Target(1) = "" Or [mémo] <> "" Then
      Application.EnableEvents = False
      Application.Undo
      Application.EnableEvents = True
    End If
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & Target(1) & Chr(34)
End Sub

Saisie multi-cellules

On veut un quadrillage si saisie en colonne A. Plusieurs cellules peuvent être saisies en même temps avec
Copier/Coller.

Private Sub Worksheet_Change(ByVal Target As Range)
  For Each c In Target
    If c.Column = 1 And c <> "" Then
      Range(c, c.Offset(, 5)).Borders.Weight = xlHairline
    End If
  Next
End Sub

Affiche des participants au survol de la salle

Affichage Participants Survol

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:D20], Target) Is Nothing Then
    For Each cel In Target
      salle = Cells(1, cel.Column)
      Set result = Sheets("plan").Cells.Find(what:=salle, LookAt:=xlPart)
      If Not result Is Nothing Then
         If result.Comment Is Nothing Then result.AddComment
            n = Application.CountA(Columns(Target.Column)) - 1
            temp = ""
            If n > 0 Then
               For Each c In Cells(2, cel.Column).Resize(n)
                  temp = temp & c & Chr(10)
               Next c
         End If
         result.Comment.Text Text:=temp & Chr(10) & n & " Places"
         result.Comment.Shape.TextFrame.AutoSize = True
         result.Value = salle & ":" & n & " Places"
       End If
     Next cel
   End If
End Sub

Application.Undo

Application.Undo permet d'annuler une saisie.

Interdit la suppression en colonne A si B ou C contient une valeur

SupInterdit

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, [a2:a30]) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    If Cells(Target.Row, 2) <> "" Or Cells(Target.Row, 3) <> "" Then
       Application.Undo
       MsgBox "Interdit"
    End If
  End If
  Application.EnableEvents = True
End Sub

Interdit la saisie de doublons

L'ancienne valeur est restituée.

Undo

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    If Application.CountIf([A:A], Target) > 1 And Target <> "" Then
      MsgBox "Doublon"
      Application.Undo
    End If
  End If
End Sub

Contrôle l'effacement dans un champ

UndoSup

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A1:C10], Target) Is Nothing Then
    If Target(1) = "" Then
      If MsgBox("Etes vous sûr? ", vbYesNo) <> vbYes Then
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
      End If
    End If
  End If
End Sub

Mémorise l'ancienne valeur dans la colonne à droite

Mémorise anc valeur

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:A65000], Target) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    ValSaisie = Target
    Application.Undo
    Target.Offset(0, 1) = Target
    Target = ValSaisie
    Application.EnableEvents = True
  End If
End Sub

Les nombres saisis dans une cellule se cumulent.

Cumul et historique
Historique des cellules modifiées

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    Application.EnableEvents = False
    ValSaisie = Target
    Application.Undo
    Target = ValSaisie + Target
    Application.EnableEvents = True
  End If
End Sub

Tri dynamique

TriDyn
Tri Dynamique

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([A2:b1000], Target) Is Nothing And Target.Count = 1 Then
    [A2:a1000].Copy [e2]
    [b2:b1000].Copy [d2]
    [d2:E1000].CurrentRegion.Sort Key1:=[d2], Header:=xlGuess
  End If
End Sub

Worksheet_SelectionChange()

Cet événnement est activé à chaque fois que l'opérateur sélectionne une cellule.

Positionne la ligne active en haut de l'écran

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  ActiveWindow.ScrollRow = ActiveCell.Row
End Sub

Positionne la ligne active au milieu de l'écran

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If ActiveCell.Row > 12 Then
     ActiveWindow.ScrollRow = ActiveCell.Row - 12
  End If
End Sub

Ouvre une liste lorsque la cellule est sélectionnée

La liste (Données/Validation) est ouverte lorsque la cellule A2 est sélectionnée.

DVSendKey

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$A$2" And Target.Count = 1 Then
     SendKeys "%{down}"
  End If
End Sub

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

Affiche une bulle aide en fonction du champ

Lorsque l'opérateur clique sur une cellule d'un champ champ, une bulle d'aide apparaît.

BulleAideChamp

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   On Error Resume Next
   Shapes("ShapeAide").Visible = False
   If Not Intersect(Union([Champ1], [Champ2]), Target) Is Nothing And Target.Count = 1 Then
     On Error Resume Next
     Shapes("ShapeAide").Visible = True
     If Err <> 0 Then creeShapeSiDetruit: Target.Select
     Shapes("ShapeAide").Left = ActiveCell.Left
     Shapes("ShapeAide").Top = ActiveCell.Top + ActiveCell.Height + 3
     If Not Intersect([Champ1], Target) Is Nothing Then texteAide = "Bulle aide sur champ1!"
     If Not Intersect([Champ2], Target) Is Nothing Then texteAide = "Bulle aide sur champ2!"
     Shapes("ShapeAide").TextFrame.Characters.Text = texteAide
   End If
End Sub

Sub creeShapeSiDetruit()
  Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 80, 10).Select
  Selection.Font.Name = "Verdana"
  Selection.Font.Size = 7
  Selection.Name = "ShapeAide"
  Shapes("ShapeAide").Left = ActiveCell.Left
  Shapes("ShapeAide").Top = ActiveCell.Top + ActiveCell.Height + 3
End Sub

Modifie le texte en fonction de la couleur choisie

CouleurEcrit

Dim celluleAvant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not IsEmpty(celluleAvant) Then
    If Not Intersect(Range(celluleAvant), [B:B]) Is Nothing Then
       Select Case Range(celluleAvant).Interior.ColorIndex
         Case 3
           Range(celluleAvant) = "rouge"
         Case 6
           Range(celluleAvant) = "jaune"
         Case 4
           Range(celluleAvant) = "Vert"
         Case Else
           Range(celluleAvant) = Empty
       End Select
     End If
   End If
   celluleAvant = Target.Address
End Sub

Curseur en couleur

Restitue l'ancienne couleur

Curseur

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   On Error Resume Next
   If [mémoAdresse] <> "" Then Range([mémoAdresse]).Interior.ColorIndex = [mémoCouleur]
   ActiveWorkbook.Names.Add Name:="mémoAdresse", RefersToR1C1:=""
   If Not Intersect([A1:D20], Target) Is Nothing And Target.Count = 1 Then
      ActiveWorkbook.Names.Add Name:="mémoAdresse", RefersToR1C1:="=" & Chr(34) & Target.Address &        Chr(34)
      ActiveWorkbook.Names.Add Name:="mémoCouleur", RefersToR1C1:="=" & Target.Interior.ColorIndex
      Target.Interior.ColorIndex = 6
   End If
End Sub

Worksheet_BeforeDoubleClick()

Modifie le contenu d'une cellule sur double clic

DoubleClic

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect([B2:B10], Target) Is Nothing Then Target.Value = IIf(Target.Value = "", "ok", "")
  Cancel = True
End Sub

Modifie la couleur de fond.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Interior.ColorIndex = 36 Then
     Target.Interior.ColorIndex = xlNone
  Else
     Target.Interior.ColorIndex = 36
  End If
Cancel = True
End Sub

Double clic rotation

On affiche successivement Edf,Gdf,Voiture,...

DblClicRotation

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect([A2:A15], Target) Is Nothing Then
     a = Array("Edf", "Gdf", "Voiture", "Divers", "")
    p = Application.Match(Target, a, 0)
    If IsError(p) Then
       Target = a(0)
     Else
        If p > UBound(a) Then p = 0
           Target = a(p)
        End If
        Cancel = True
     End If
End Sub

Double cliquer sur le titre pour cacher ou faire apparaitre les sous-titres

DoubleClic
DoubleClicGroupe

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If ActiveCell.Column = 2 And ActiveCell.Font.Bold = True Then
     If Not ActiveCell.Offset(1, 0).EntireRow.Hidden Then
        i = 1
        Do While Not ActiveCell.Offset(i, 0).Font.Bold And Not IsEmpty(ActiveCell.Offset(i, 0))
          i = i + 1
        Loop
        ActiveCell.Offset(1, 0).Resize(i - 1).EntireRow.Hidden = True
      Else
        i = 1
        Do While ActiveCell.Offset(i, 0).EntireRow.Hidden
          i = i + 1
        Loop
        ActiveCell.Offset(1, 0).Resize(i - 1).EntireRow.Hidden = False
     End If
     Cancel = True
   End If
End Sub

Double cliquer sur un niveau d'indentation pour cacher les niveaux inférieurs

Masque indent

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect([A2:A1000], Target) Is Nothing And Target.Count = 1 And Target <> "" Then
     niveau = Target.IndentLevel
     masque = Not Target.Offset(1, 0).EntireRow.Hidden
     i = 1
     Do While Target.Offset(i).IndentLevel > niveau: i = i + 1: Loop
     If i > 1 Then Target.Offset(1).Resize(i - 1).EntireRow.Hidden = masque: Target.Interior.ColorIndex = IIf(masque, 4, 2)
   End If
   Cancel = True
End Sub

Evénements OnTime,Timer,Wait

Application.OnTime(temps, Procedure:=nomProc, LatestTime, Schedule:=true/false

Affichage heure

Sur cet exemple, l’heure affichée dans la cellule A1 est mise à jour toutes les secondes.

OnTimeHeure
Affichage heure formulaire
OnTime calculate
OnTime sauvegarde

Dim temps
Sub majHeure()
  ThisWorkbook.Sheets("feuil1").[A1] = Now
  temps = Now + TimeValue("00:00:1")
  Application.OnTime temps, "majHeure"
End Sub

Sub auto_open()
   majHeure
End Sub

Sub auto_close()
   On Error Resume Next
   Application.OnTime temps, Procedure:="majHeure", Schedule:=False
End Sub

Ferme le classeur automatiquement à une heure

Sub auto_open()
  heure = "18:45:00"
  Application.OnTime EarliestTime:=TimeValue(heure), Procedure:="ferme"
End Sub

Sub ferme()
   ActiveWorkbook.Close savechanges = True
End Sub

Ferme le classeur automatiquement après un délai

OnTime Ferme Délai

Dans un module:

Public HeureFermeture
Sub FermeClasseur()
  ActiveWorkbook.Close True
End Sub

Dans thisWorkbook

Private Sub Workbook_Open()
   HeureFermeture = Now + TimeValue("00:1:00")
   Application.OnTime HeureFermeture, "FermeClasseur"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnTime EarliestTime:=HeureFermeture, Procedure:="fermeClasseur", Schedule:=False
End Sub

Ferme le classeur après un temps d'inactivité dans les feuilles de calcul

OnTimeInactif
OnTime Inactif2

Dans un module:

Public HeureArrêt

Sub ProchainArret()
   HeureArrêt = Now + TimeValue("00:02:00")
   Application.OnTime HeureArrêt, "Fin"
   Sheets(1).[A1]=HeureArrêt
End Sub

Sub Fin()
  On Error Resume Next
  Application.OnTime HeureArrêt, Procedure:="Fin", Schedule:=False 'annule événnement
  ThisWorkbook.Close True
End Sub

Dans ThisWorkBook:

Private Sub Workbook_Open()
  ProchainArret
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   On Error Resume Next
   Application.OnTime HeureArrêt, Procedure:="Fin", Schedule:=False
   ProchainArret
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
'ThisWorkbook.Saved = True
On Error Resume Next
Application.OnTime HeureArrêt, Procedure:="Fin", Schedule:=False ' annule événnement
End Sub

Clignotement d'une cellule

OnTime Clignote
Clignote 10 Fois
Texte Défilant

Dim t As Integer
Dim temps
Sub clignote()
  If t = 0 Then
     Range("A1").Interior.ColorIndex = 6
     t = 1
  Else
    Range("A1").Interior.ColorIndex = 2
    t = 0
  End If
  temps = Now + TimeValue("00:00:01")
  Application.OnTime EarliestTime:=temps, Procedure:="clignote"
End Sub

Sub clignote_pas()
   Application.OnTime EarliestTime:=temps, Procedure:="clignote", Schedule:=False
End Sub

Timer

Donne en secondes le temps (depuis minuit)

Ontime

Sub auto_open()
   t = "ceci est texte défilant dans une cellule......"
   n = 0
   Do While n < 500
     t = Right(t, 1) & Left(t, Len(t) - 1)
     [A1] = t
     w = 0.2
     temp = Timer
     Do While Timer < temp + w
       DoEvents
    Loop
    n = n + 1
  Loop
End Sub

Tempo non bloquante

Sub TempoNonBloquante(t)
   fin = Timer + t
   Do While Timer < fin
     DoEvents
   Loop
End Sub

Chronomètre

Sub chrono()
   début = Timer
   For i = 1 To 100000
     DoEvents
   Next i
   ecart = Timer - début
   MsgBox ecart
End Sub

Autre exemple

Le chrono est déclenché par le bouton démarre.

ChronoSimple

Public départ, fin
Sub demarre()
  départ = Timer
  fin = False
  Do While Not fin
    [A1] = Format((Timer() - départ) / 3600 / 24, "hh:mm:ss")
    DoEvents
  Loop
End Sub

Sub arret()
  fin = True
End Sub

Chronomètre de gestion de tâches

-Pointer sur la cellule à droite de la tâche
-Bouton démarrer
-Bouton Arrêt

ChronoTache
OnTime Chrono
OnTimeDecompte

Public départ, fin
Sub demarre()
  If ActiveCell.Column = 2 And Cells(ActiveCell.Row, 1) <> "" Then
    départ = Timer
    ancien = ActiveCell * 24 * 3600
    c = ActiveCell.Address
    fin = False
    Do While Not fin
      Range(c) = Format((Timer + ancien - départ) / 3600 / 24, "hh:mm:ss")
      DoEvents
    Loop
  End If
End Sub

Sub arret()
   fin = True
End Sub

Sub raz()
   [B2:B8].ClearContents
End Sub

Application.Wait temps

Sub tempoBlocante()
    Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 5)
    Range("A1") = "fin"
End Sub

OnKey touche,NomProcédure

Désactiver la touche Suppr

Sub auto_open()
  Application.OnKey "{DEL}", ""
End Sub

Sub auto_close()
  Application.OnKey "{DEL}"
End Sub

Empêcher la suppression de formes avec la touche sup

Sub auto_open()
   Application.OnKey "{del}", "maproc"
End Sub

Sub maproc()
  If TypeName(Selection) = "Rectangle" Then
     MsgBox "Interdit"
  End If
  If TypeName(Selection) = "Range" Then
     Selection.ClearContents
  End If
End Sub

Sub auto_close()
Application.OnKey "{del}"
End Sub

MouseMove

Image au survol d'un bouton dans un formulaire

Survol Bouton Formulaire

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Me.Image1.Visible = True
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Me.Image1.Visible = False
End Sub

Affichage d'une bulle au survol d'une image dans le tableur

La façon la plus simple est d'affecter des hyperliens aux images.
On ne maîtrise pas la position de l'affichage de la bulle.

Bulle image
Créer info-bulle Images2

Sub bulles()
  For Each s In ActiveSheet.Shapes
     If s.Type = 13 Then
        ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
        s.Hyperlink.ScreenTip = s.Name
     End If
  Next s
End Sub

Autre façon

On affiche une zone de texte au survol d'une image.

-Créer une zone de texte et la nommer MonShape
-Avec la BO Boite à outils contrôle, créer une image
-Dans les propriétes, choisir l'image dans Picture

Survol Image
Survol Image activation macro

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
     ActiveSheet.Shapes("monshape").Visible = False
   Else
     ActiveSheet.Shapes("monshape").Visible = True
   End If
End Sub

Changement de couleur du bouton au survol

Survol Bouton

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > CommandButton1.Width - 10 Or Y < 10 Or Y > CommandButton1.Height - 10 Then
     Me.CommandButton1.BackColor = RGB(255, 0, 0)
  Else
     Me.CommandButton1.BackColor = RGB(0, 255, 0)
  End If
End Sub

Private Sub CommandButton1_Click()
   Me.CommandButton1.BackColor = RGB(255, 0, 0)
   UserForm1.Show
End Sub

Info-bulle au survol d'un bouton ActiveX dans le tableur

Par hyper lien

Sub HyperLienBoutonActiveX()
  Set s = ActiveSheet.Shapes(MonBouton")
  ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
  s.Hyperlink.ScreenTip = "coucou au survol"
End Sub

En utilisant l'événement MouseMove

Bouton Survol

Private Sub Bouton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Bouton1.Width - 10 Or Y < 10 Or Y > Bouton1.Height - 10 Then
    ActiveSheet.Shapes("monshape").Visible = False
  Else
    ActiveSheet.Shapes("monshape").Visible = True
  End If
End Sub

Bulle au survol d'une forme

La cellule sous la forme contient un commentaire.

Bulle sur une forme

Affichage d'une image au survol d'une cellule

Visualise une image nommée chateau au survol de la partie rouge de B2.

Survol Cellule
Survol Forme

-Incorporer en B2 un label Label1 avec la BO contrôle (A)
-Dans Caption ,écrire ?
-Police Windings3

Dans l'événement MouseMove:

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
    ActiveSheet.Shapes("chateau").Visible = False
  Else
   ActiveSheet.Shapes("chateau").Visible = True
  End If
End Sub

Inversion d'image au survol

Image Interne Survol

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Image1.Picture = _
  IIf((X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10), Sheets("photos").Image1.Picture,       Sheets("photos").Image2.Picture)
End Sub

Form Image Interne Survol
Form Image Externe Survol
Image Externe Survol

Survol d'une partie de photo

La propriété ControlTipText des labels invisibles crées permet d'afficher un commentaire au survol.

Bulles photos 1

On modifie les propriétés des labels au survol.

Bulles photos 2

Dim Lbl(1 To 23) As New ClasseLabel
Private Sub UserForm_Initialize()
  i = 0
  For Each c In Me.Controls
    temp = c.Name
    If TypeName(c) = "Label" And temp <> "Commentaire" Then
      i = i + 1
      Set Lbl(i).GrLabels = Me(temp)
    End If
  Next c
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Me.Commentaire.Visible = False
End Sub

Public WithEvents GrLabels As Msforms.Label
  Private Sub GrLabels_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  bulle = Application.VLookup(GrLabels.Name, [légendes], 2, False)
  If Not IsError(bulle) Then
    UserForm1.Commentaire.Caption = bulle
    UserForm1.Commentaire.Left = GrLabels.Left
    UserForm1.Commentaire.Top = GrLabels.Top - 20
    UserForm1.Commentaire.Visible = True
  End If
End Sub

Zoom d'un champ au survol du champ

Zoom Champ Survol
Graphique Survol Champ

1-Edition/copier du champ E1:I6
2-Maj+Edition/coller image avec liaison
3-Agrandir la copie
4-Nommer la copie Monca
5-Avec la Boîte à outils Contrôle, créer une image Image1
6-La superposer sur le champ
7-La rendre transparente:propriété backstyle: fmBackstyleTransparent

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 10 Or X > Image1.Width - 10 Or Y < 10 Or Y > Image1.Height - 10 Then
      ActiveSheet.Shapes("Monca").Visible = False
  Else
      ActiveSheet.Shapes("monca").Visible = True
  End If
End Sub

Private Sub Image1_Click()
  ActiveSheet.Image1.Visible = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   On Error Resume Next
  ActiveSheet.Image1.Visible = True
End Sub

Visualisation d'un champ au survol d'une cellule

Visu Champ Survol

-Sélectionner le champ à afficher(J1:N5)
-Edition/Copier puis appuyer sur la touche Maj /Edition coller l'image avec liaison et nommer le shape MonCa(en haut à gauche de la barre de formule)
ou
-Avec l'appareil photo, photographier le champ à visualiser et nommer le shape MonCa

-Incorporer en B2 un label Label1 avec la Barre Outils Boîte à outils contrôles
-Le colorier en rouge
-Double-clic

Dans l'événement MouseMove:

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
      ActiveSheet.Shapes("monca").Visible = False
  Else
      ActiveSheet.Shapes("monca").Visible = True
  End If
End Sub

-Désactiver l'équerre de la Barre Outils Boîte à outils contrôles

Changement de la taille d'un label au survol

Survol Taille Label

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
     Label1.Font.Bold = False
     Label1.Font.Size = 12
  Else
     Label1.Font.Bold = True
     Label1.Font.Size = 20
  End If
End Sub

Modifie la couleur de la cellule B2 au survol de celle ci

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.

Lorsque l'opérateur clique sur la cellule, le label n'est plus visible et la saisie dans la cellule est ainsi autorisée.

SurvolCellule

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
    [B2].Interior.ColorIndex = xlNone
  Else
    [B2].Interior.ColorIndex = 3
  End If
End Sub

Private Sub Label1_Click()
  [B2].Select
  [B2].Interior.ColorIndex = 36
  ActiveSheet.Label1.Visible = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  [B2].Interior.ColorIndex = xlNone
  ActiveSheet.Label1.Visible = True
End Sub

Pour que la taille du label soit modifiée automatiquement si la taille de la cellule B2 est modifiée, ajouter dans Label Click

ActiveSheet.Label1.Width = [B2].Width
ActiveSheet.Label1.Height = [B2].Height
ActiveSheet.Shapes("label1").Top = [B2].Top + 1
ActiveSheet.Shapes("label1").Left = [B2].Left + 1

Survol d'une cellule d'un champ

Dans le champ B2:D5 (nommé Champ), la couleur de la cellule survolée est modifiée.

-Nommer le champ B2:D5(champ)
-Avec la boîte à outils Contrôles, créer un label Label1 transparent avec A
-Le positionner sur le champ.

Survol Champ
Survol Champ Shapes
Curseur Survol Champ
Survol Shapes

Dim Xc, Yc
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
     Range("champ").Interior.ColorIndex = xlNone
  Else
     Hcel = Range("champ").Cells(1, 1).Height
     Lcel = Range("champ").Cells(1, 1).Width
     Yc = Int(Y / Hcel)
     Xc = Int(X / Lcel)
     Range("champ").Interior.ColorIndex = xlNone
     Range("champ").Cells(1, 1).Offset(Yc, Xc).Interior.ColorIndex = 3
     Range("champ").Cells(1, 1).Offset(Yc, Xc).Select
   End If
End Sub

Private Sub Label1_Click()
  Range("champ").Interior.ColorIndex = xlNone
  Range("champ").Cells(1, 1).Offset(Yc, Xc).Select
  Range("champ").Cells(1, 1).Offset(Yc, Xc).Interior.ColorIndex = 4
  ActiveSheet.Label1.Visible = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Range("champ").Interior.ColorIndex = xlNone
  ActiveSheet.Label1.Visible = True
End Sub

Si la largeur des colonnes est modifiée, les instructions suivantes ajoutées dans Label_Click modifient la largeur de Label1 automtiquement

ActiveSheet.Label1.Width = Range("champ").Width
ActiveSheet.Label1.Height = Range("champ").Height
ActiveSheet.Shapes("label1").Top = Range("champ").Top + 1
ActiveSheet.Shapes("label1").Left = Range("champ").Left + 1

Affichage du contenu d'une cellule (info-bulle) au survol dans un shape

SuvolCelluleChamp

Visualisation et modification du contenu des cellules d'un champ dans un formulaire au survol.

Visualise la cellule survolée dans un formulaire. On peut également modifier le contenu de la cellule dans le formulaire.

Survol Champ Form
Survol Cellule Form Photo
Survol Champ Form2

Pour modifier dans la cellule:
-cliquer sur la cellule (qui devient verte)
-modifier
-valider avec Entrée

Pour modifier dans le formulaire:
-Cliquer dans la cellule (qui devient verte)
-Cliquer dans le formulaire.
-Modifier
-Cliquer sur ok

Survol texte dans un formulaire

SurvolTexte

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 5 Or X > Label1.Width - 5 Or Y < 5 Or Y > Label1.Height - 5 Then
    Me.Image1.Visible = False
    Me.Label1.ForeColor = vbBlack
  Else
    Me.Image1.Visible = True
    Me.Label1.ForeColor = vbRed
  End If
End Sub

Commentaire dynamique

Visualise le texte de la cellule F1 (info-bulle) au survol de la partie rouge de B2

Survol Texte -

-Créer une zone de texte et la nommer MonShape
-Incorporer en B2 un label Label1 avec la BO contrôle
-Le colorier en rouge

Dans l'événement MouseMove:

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  d = 3
  If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
     ActiveSheet.Shapes("monshape").Visible = False
  Else
     Shapes("monshape").Fill.ForeColor.SchemeColor = 13
     Shapes("monshape").TextFrame.Characters.Text = [F1]
     ActiveSheet.Shapes("monshape").Visible = True
  End If
End Sub

Visualisation de photos en grand au survol de photos miniatures

Survol photos

Calculate

L'événement Calculate est activé à chaque modification de cellule dans le classeur.

Sur cet exemple, on affiche un shape nommé MonShape si A10 dépasse la valeur 100.

Calculate

Private Sub Worksheet_Calculate()
   ActiveSheet.Shapes("monshape").Visible = ([A10] > 100)
End Sub

Détecte la modification de la valeur d'une cellule qui contient une formule

Sur cet exemple, on teste si la valeur en A8 varie. Le nom Mémo donne l'ancienne valeur.

Private Sub Worksheet_Calculate()
   If [A8] <> CDbl([mémo]) Then
      MsgBox [mémo]
      ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & [A8] & Chr(34)
   End If
End Sub

Private Sub Workbook_Open()
   ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & Sheets(2).[A8] & Chr(34)
End Sub

Exemples

Mémorise l'historique des cellules modifiées sur un onglet (nommé Espion)

Espion cellules modifiées

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Sh.Name <> "Espion" Then
    Application.EnableEvents = False
    ValSaisie = Target
    Application.Undo
    temp = Application.CountA(Sheets("espion").Range("a:a")) + 1
    Sheets("espion").Cells(temp, 1) = Sh.Name
    Sheets("espion").Cells(temp, 2) = Target.Address
    Sheets("espion").Cells(temp, 3) = Now
    Sheets("espion").Cells(temp, 4) = Target
    Sheets("espion").Cells(temp, 5) = ValSaisie
    Sheets("espion").Cells(temp, 6) = Environ("username")
    Application.EnableEvents = True
  End If
End Sub

Editeur de cellule

Permet de modifier une cellule à partir d'un formulaire.

EditeurCellule

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target <> "" Then
    UserForm1.TextBox1 = Target
    UserForm1.Show
  End If
  Cancel = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
UserForm1.Hide
End Sub

Private Sub TextBox1_Change()
ActiveCell = Replace(Me.TextBox1, Chr(13), "")
End Sub

Mettre en Gras les dates dans une chaîne

Une date de début et une date de fin sont saisis en B1 et B2.
On veut créer en A5 la chaîne ci dessous à la saisie des dates:

Le Bailleur loue au Preneur le logement du lundi 01 janvier 2018 au mardi 01 janvier 2019

Dates en gras

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([B1:B2], Target) Is Nothing Then
    Dim Résult As Range
    Set Résult = Range("a5")
    ch1 = "Le Bailleur loue au Preneur le logement du "
    ch2 = " au "
    date1 = Format([b1], "dddd dd mmmm yyyy")
    date2 = Format([b2], "dddd dd mmmm yyyy")
    Résult = ch1 & date1 & ch2 & date2 & ch3
    Résult.Characters(Start:=Len(ch1) + 1, Length:=Len(date1)).Font.Bold = True
    Résult.Characters(Start:=Len(ch1) + Len(date1) + Len(ch2) + 1, Length:=Len(date2)).Font.Bold = True
End If
End Sub

Colorie les cellules modifiées

ColoriageModif

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False ' désactive les événements
If C_activation And Target.Count = 1 Then
ActiveSheet.Unprotect
Target.Interior.ColorIndex = 3
Range("G8") = Range("G8") + 1
ActiveSheet.Protect
End If
Application.EnableEvents = True
End Sub

Sub raz()
Application.EnableEvents = False
ActiveSheet.Unprotect
Range("b2:d14").Interior.ColorIndex = 2
Range("G8") = 0
ActiveSheet.Protect
Application.EnableEvents = True
End Sub

Autre version

Restitue l'ancienne couleur (stockée dans un tableau).

ColoriageModif

Dim adresse(1000), couleur(1000)
Dim nbc As Integer
Dim activation As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
  If C_activation Then
    If Not Intersect([B2:E14], Target) Is Nothing And Target.Count = 1 Then
      ActiveSheet.Unprotect
      adresse(nbc) = Target.Address
      couleur(nbc) = Target.Interior.ColorIndex
      Target.Interior.ColorIndex = 3
      nbc = nbc + 1
      ActiveSheet.Protect
    End If
  End If
End Sub

Sub restitue()
  ActiveSheet.Unprotect
  For j = 0 To nbc - 1
    Range(adresse(j)).Interior.ColorIndex = couleur(j)
  Next j
  nbc = 0
  ActiveSheet.Protect
End Sub

Colorie les cellules résultats (formules) dont la valeur source a été modifiée dans saisie1,saisie2,...

ColoriageCellulesModifiées

Dans un module

Public tbl(100), n

Dans la feuille Globale

Private Sub Worksheet_Activate()
  For Each c In Cells.SpecialCells(xlCellTypeFormulas, 23)
    For i = 1 To n
       If InStr(Replace(c.Formula, "$", ""), tbl(i)) > 0 Then c.Interior.ColorIndex = 36
    Next i
  Next c
End Sub

Pour effacer les coloriages

Sub raz()
Cells.SpecialCells(xlCellTypeFormulas, 23).Interior.ColorIndex = xlNone
For i = 1 To n
Range(tbl(i)).Interior.ColorIndex = xlNone
Next i
n = 0
End Sub

SendKeys

Affiche les items d'une colonne sur le clic dans la première cellule vide.

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

WebBrowser

L'objet WebBrowser permet de visualiser une URL dans un classeur Excel.

WebBrowser

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([champ], Target) Is Nothing Then
    monurl = Target.Offset(, 1)
    [C2] = monurl
    Call Sheets("feuil1").WebBrowser1.Navigate(monurl)
    Target.Select
    Sheets("feuil1").WebBrowser1.Top = 100 + Cells(ActiveWindow.ScrollRow, 1).Top
  End If
End Sub