Accueil

 

Création d'un commentaire Efface les commentaires Masquage et affichage des commentaires Autosize la taille des zones commentaires Modification de la taille de zones commentaire Remplace un texte par un autre Modifie la couleur de fond des commentaires Modifie la couleur d'une chaîne cherchée Modifie la forme Modifie l'image de fond Récupère le commentaire d'une cellule Extrait les commentaires Liste des commentaires d'un classeur Liste des commentaires d'une feuille Insertion de commentaires Supprime les sauts de ligne Récupére le commentaire d'une liste Modifie la taille de la zone commentaire Modifier le couleur des triangles rouges des commentaires Position des commentaires Affiche commentaire position choisie Date du jour et nom Commentaires visibles pour un seul utilisateur

-Insère image en commentaire dans la cellule active -Photos en commentaire -Commentaire Sans Nom User -Commentaire avec date jour double-clic -Fonction d'affichage d'un commentaire -Affichage en info-bulle du contenu d'une cellule -Fonction d'affichage d'une photo -Fonction de clônage d'un commentaire -Fonction d'affichage d'un commentaire 2 -Commentaire avec date jour clic droit -Planning -Photos en commentaire -Calendrier en commentaire -Historique d'une cellule -Modifier la forme d'un commentaire -Forme du commentaire en fonction du User -Impression indicateur de commentaire -Transfert dynamique de commentaire -Commentaire dynamique -Edition fiche avec photo commentaire -MFC sur commentaire -Filtre sur commentaire -Commentaires invisibles au survol -Commentaire partagé -Commentaire propriétaire -Copie d'un champ dans un commentaire -Récupération d'un commentaire image -Commentaire structuré -Saisie d'un commentaire dans un formulaire -Noms de champ en commentaire -Formules en commentaire -Affiche participants au survol de la salle

Création d'un commentaire dans une cellule

With Range("A1")
 If .Comment Is Nothing Then
  .AddComment ' Création commentaire
  .Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
  .Comment.Shape.OLEFormat.Object.Font.Size = 7
  .Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
  .Comment.Text Text:="Ceci est un commentaire..."
  .Comment.Shape.TextFrame.AutoSize = True
 End If
End With

Efface les commentaires du champ sélectionné

Sub EffaceCmt()
  On Error Resume Next
  Selection.ClearComments
End Sub

Masque/Affiche les commentaires

Masque et affiche tous les commentaires dans la feuile active.

Sub MasqueCmt()
  On Error Resume Next
  For Each c In ActiveSheet.Comments
    c.Visible = False
  Next c
End Sub

Sub AfficheCmt()
  On Error Resume Next
  For Each c In ActiveSheet.Comments
    c.Visible = True
  Next c
End Sub

Indicateur affiché seulement

SubIndicateur()
   Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub

Commentaire et indicateur affichés

Sub CommentIndicateur()
   Application.DisplayCommentIndicator = xlCommentAndIndicator
End Sub

AutoSize la taille des commentaires

Sub AutoSize()
  For Each c In ActiveSheet.Comments
    c.Shape.TextFrame.AutoSize = True
  Next c
End Sub

Modification de la taille zone commentaire

Sub tailleZoneCommentaire()
  For Each c In ActiveSheet.Comments
    c.Shape.Width = 60
    c.Shape.Height = 40
  Next c
End Sub

Remplace un texte par un autre

Remplace 2006 par 2007 dans tous les commentaires de la feuille.

Sub ModifieCommentaire()
  For Each c In ActiveSheet.Comments
    c.Text Text:=Replace(c.Text, "2006", "2007")
  Next c
End Sub

Supprime le nom utilisateur dans les commentaires déja saisis

Sub SupprimeNom()
   For Each c In ActiveSheet.Comments
     c.Text Text:=Replace(c.Text, Application.UserName & ":" & Chr(10), "")
   Next c
End Sub

Modifie la couleur de fond

Modifie la couleur de fond de tous les commentaires de la feuille.

Sub commentaireCouleur()
  For Each c In ActiveSheet.Comments
    c.Shape.Fill.ForeColor.SchemeColor =52
  Next c
End Sub

Modifie la couleur des commentaires en fonction d'un mot contenu dans le commentaire.

CommentaireCouleur

Modifie la couleur d'une chaîne cherchée dans un commentaire

Set cel = Range("g1")
chaineCherchée = "produit:"
p = InStr(cel.Comment.Text, chaineCherchée)
If p > 0 Then
   cel.Comment.Shape.TextFrame.Characters(Start:=p, Length:=Len(chaineCherchée)).Font.ColorIndex = 3
End If

Si la chaîne cherchée existe plusieurs fois

Set cel = Range("g1")
chaineCherchée = "produit:"
p = 1
Do While p > 0
  p = InStr(p, cel.Comment.Text, chaineCherchée)
  If p > 0 Then
    cel.Comment.Shape.TextFrame.Characters(Start:=p, Length:=Len(chaineCherchée)).Font.ColorIndex = 3
    p = p + Len(chaineCherchée)
  End If
Loop

Visualise les commentaires contenant un mot cherché

CmtMotCherché

Sub ContientMot()
  mot = "Paris"
  For Each c In ActiveSheet.Comments
    c.Visible = (InStr(c.Text, mot) > 0)
  Next c
End Sub

Sub Sup1000()
   For Each c In ActiveSheet.Comments
     c.Visible = (c.Parent >= 1000)
   Next c
End Sub

Historique de saisie d'une cellule

Mémorise l'historique des cellules dans la zone commentaire des cellules.

Commentaire Historique Cellule
Historique des dates saisies dans une cellule

-Alt+F11
-Double clic sur Feuil1
-Choisir WorkSheet
-Choisir événement Change

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.EnableEvents = False
  If Target.Column = 3 And Target.Count = 1 Then ' colonne 3 seulement
    If Target.Comment Is Nothing Then Target.AddComment ' Création commentaire
        Target.Comment.Text Text:=Target.Comment.Text & _
           Format(Target.Value, "# ##0.00 €") & " Modifié par:" & Environ("UserName") & _
             " Le " & Now & vbLf
       Target.Comment.Shape.TextFrame.AutoSize = True
     End If
     Application.EnableEvents = True
End Sub

Modifie la forme des commentaires

Modifie la forme de tous les commentaires de la feuille.

Sub RectangleArrondi()
  For Each c In ActiveSheet.Comments
     c.Shape.AutoShapeType = msoShapeRoundedRectangle
  Next c
End Sub

Sub HorizontalScroll()
   For Each c In ActiveSheet.Comments
    c.Shape.AutoShapeType = msoShapeHorizontalScroll
   Next c
End Sub

Formes Commentaires

Image de fond

Ajoute une image de fond aux commentaires

Sub ImageFondCommentaire()
  ChDir ActiveWorkbook.Path
  For Each c In ActiveSheet.Comments
    c.Shape.Fill.UserPicture "fond_nico.jpg"
    c.Shape.Height = 100
    c.Shape.Width = 100
    c.Shape.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft
    c.Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
  Next c
End Sub

Insère une image en commentaire dans la cellule Active

L'insertion d'une image dans un commentaire avec la commande
Format/commentaire/Couleurs et traits/remplissage/couleur/motifs et textures/Images est fastidieux.

Le programme ci dessous permet de choisir directement l'image.

InsereImageCommentaire

Sub InsèreImageCommentaireCelluleActive()
  nf = Application.GetOpenFilename("Fichiers jpg,*.jpg")
  If nf = False Then Exit Sub
  With ActiveCell
    .ClearComments
    .AddComment
    .Comment.Shape.Fill.UserPicture nf
    .Comment.Shape.Height = 50
    .Comment.Shape.Width = 50
    .Comment.Shape.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft
   End With
End Sub

Version avec choix de l'échelle

InsereImageCommentaire2

Sub InsèreImageCommentaireCelluleActive()
  nf = Application.GetOpenFilename("Fichiers jpg,*.jpg")
  If nf = False Then Exit Sub
  ech = Application.InputBox("Echelle?", Type:=1, Default:=1)
  If ech = 0 Then Exit Sub
  With ActiveCell
    .ClearComments
    .AddComment
    .Comment.Shape.Fill.UserPicture nf
    p = InStrRev(nf, "\")
    repertoire = Left(nf, p)
    fichier = Mid(nf, p + 1)
    taille = TaillePixelsImage(repertoire, fichier)
    .Comment.Shape.Height = Val(Split(taille, "x")(1))
    .Comment.Shape.Width = Val(Split(taille, "x")(0))
    .Comment.Shape.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
    .Comment.Shape.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
   End With
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Conversion de photos en commentaire vers des images internes ou des fichiers JPG

ConvCmtJPG

Modifie la taille de la police des commentaires d'une feuille

Sub ModifPoliceTous10()
  For Each i In ActiveSheet.Comments
    i.Shape.OLEFormat.Object.Font.Size = 10
  Next i
End Sub

Sub ModifPoliceTous8()
   For Each i In ActiveSheet.Comments
     i.Shape.OLEFormat.Object.Font.Size = 8
   Next i
End Sub

Modifie la police d'une partie de commentaire

Sub ModifPolice()
   For Each i In ActiveSheet.Comments
     i.Shape.OLEFormat.Object.Font.Name = "Verdana"
     i.Shape.OLEFormat.Object.Font.Size = 8
     i.Shape.TextFrame.Characters(Start:=14, Length:=10).Font.Size = 10
   Next i
End Sub

Sub ModifPolice2()
  For Each i In ActiveSheet.Comments
     i.Shape.TextFrame.Characters(Start:=14, Length:=99).Font.Bold = True
  Next i
End Sub

Fonction de récupération commentaire

RecupCommentaire

Function RecupCommentaire(c)
   Application.Volatile
   If c.Comment Is Nothing Then
     RecupCommentaire = ""
   Else
     RecupCommentaire = Replace(c.Comment.Text, Chr(10), " ")
   End If
End Function

Récupère les caractères italiques d'un commentaire

Function RecupItalique(c)
   Application.Volatile
   temp = ""
   For i = 1 To Len(c.Comment.Text)
     If c.Comment.Shape.TextFrame.Characters(i, 1).Font.Italic Then
        temp = temp & Mid(c.Comment.Text, i, 1)
     End If
   Next i
   RecupItalique = temp
End Function

Compter le nombre de commentaires d'un champ qui contiennent le mot Ok

=NbCmt(A1:B10;"ok";"feuil2")

Function NbCmt(champ As Range, Cmt, Optional onglet)
  Application.Volatile
  If IsMissing(onglet) Then onglet = ActiveSheet.Name
  For Each c In Sheets(onglet).Comments
    If Not Intersect(Sheets(onglet).Range(champ.Address), c.Parent) Is Nothing Then
       If InStr(UCase(c.Text), UCase(Cmt)) > 0 Then n = n + 1
    End If
  Next c
  NbCmt = n
End Function

Fonction de recopie d'une cellule avec commentaire

FonctionRecopieCelCmt

Function CopieCelCmt(cel)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  Set adr = f.Range(Application.Caller.Address)
  If cel.Comment Is Nothing Then
     adr.Comment.Delete
  Else
     If adr.Comment Is Nothing Then adr.AddComment
     adr.Comment.Text Text:=cel.Comment.Text
     adr.Comment.Shape.Height = cel.Comment.Shape.Height
     adr.Comment.Shape.Width = cel.Comment.Shape.Width
     On Error Resume Next
     adr.Comment.Shape.Fill.ForeColor.SchemeColor = _
       cel.Comment.Shape.Fill.ForeColor.SchemeColor
   End If
   CopieCelCmt = cel
End Function

Extrait les commentaires

Sub ExtraitCommentaire()
  For Each c In Range("A2", [A65000].End(xlUp))
     c.Offset(0, 2) = c.Comment.Text
  Next c
End Sub

Parcourir les commentaires d'un champ avec Find

Sub ChercheComments()
  Set champ = Range("A1:C10")
  champ.Interior.ColorIndex = xlNone
  Set C = champ.Find(what:="*", LookIn:=xlComments)
  If Not C Is Nothing Then
    premier = C.Address
    Do
      C.Interior.ColorIndex = 3
      Set C = champ.FindNext(C)
      Loop While Not C Is Nothing And C.Address <> premier
   End If
End Sub

Recherche dans les commentaires avec Find

On recherche les commentaires contenant une valeur cherchée.

Sub ChercheComments()
  ValCherchée = "xxxx"
  Set champ = Range("A1:C10")
  champ.Interior.ColorIndex = xlNone
  Set C = champ.Find(what:=ValCherchée, LookIn:=xlComments)
  If Not C Is Nothing Then
    premier = C.Address
    Do
      C.Interior.ColorIndex = 4
      Set C = champ.FindNext(C)
    Loop While Not C Is Nothing And C.Address <> premier
  End If
End Sub

Liste des commentaires d'un champ dans une feuille

CommentairesListe

Sub ListeCommentaires()
  mafeuille = ActiveSheet.Name
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("TempNoms").Delete
  On Error GoTo 0
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = "TempNoms"
  Set champ = Range("A1:C10")
  ligne = 2
  For Each C In Sheets(mafeuille).Comments
    If Not Intersect(Range(C.Parent.Address), champ) Is Nothing Then
      Sheets("TempNoms").Cells(ligne, 1) = C.Parent.Address
      Sheets("TempNoms").Cells(ligne, 2) = C.Text
      ligne = ligne + 1
    End If
  Next C
End Sub

Liste des commentaires d'un classeur

CommentairesListeClasseur

Sub ListeCommentaires()
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Commentaires").Delete
  On Error GoTo 0
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = "Commentaires"
  ligne = 2
  For s = 1 To ActiveWorkbook.Sheets.Count
    For Each C In Sheets(s).Comments
      Sheets("Commentaires").Cells(ligne, 1) = Sheets(s).Name
      Sheets("Commentaires").Cells(ligne, 2) = C.Parent.Address
      Sheets("Commentaires").Cells(ligne, 3) = C.Text
      ligne = ligne + 1
    Next C
  Next s
End Sub

Récupère dans Feuil2 les commentaires de Feuil1

CommentRecup

Private Sub Worksheet_Activate()
  Set f = Sheets("feuil1")
  ligne = 2
  For Each c In f.Comments
    adr = c.Parent.Address
    Cells(ligne, 1) = f.Cells(Range(adr).Row, 1)
    Cells(ligne, 2) = f.Cells(3, Range(adr).Column)
    Cells(ligne, 3) = f.Range(adr)
    temp = c.Text
    Cells(ligne, 4) = Mid(temp, InStr(temp, ":") + 2)
    ligne = ligne + 1
  Next c
End Sub

Convertit la zone sélectionnée en commentaire

Sub AjouteCommentaire()
  Selection.ClearComments
  For Each c In Selection
    c.AddComment CStr(c.Value)
    c.Comment.Shape.TextFrame.AutoSize = True
    c.Comment.Shape.OLEFormat.Object.Font.Size = 12
  Next c
End Sub

Remplit les cellules sélectionnées avec les commentaires des cellules

Sub ConvertCommentaire()
  For Each c In Selection
     If Not c.Comment Is Nothing Then c.Value = c.Comment.Text
  Next c
End Sub

Ajoute en colonne A des commentaires avec le contenu de la colonne C

CommentaireAjoute

Sub AjouteCommentaire()
  [A:A].ClearComments
  For Each c In Range("C2", [c65000].End(xlUp))
    c.Offset(0, -2).AddComment c.Value
    c.Comment.Shape.TextFrame.AutoSize = True
  Next c
End Sub

Supprime les sauts de ligne dans les commentaires

Sub EnlèveSautLigne2()
  For Each c In Selection
   If c.NoteText <> "" Then
      c.Comment.Text Text:=Replace(c.Comment.Text, Chr(10), " ")
   End If
  Next c
End Sub

Récupérer le commentaire dans une une liste déroulante

RecupCommentaire

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address = "$A$2" Then
   Application.EnableEvents = False
   [MaListe].Find(Target, LookAt:=xlWhole).Copy
   Target.PasteSpecial Paste:=xlPasteComments
   Application.EnableEvents = True
  End If
End Sub

Modifie la taille de la zone commentaire

Sub tailleZoneCommentaire()
  For Each c In ActiveSheet.Comments
    c.Shape.Width = 60
    c.Shape.Height = 40
    c.Shape.Left = c.Parent.Left + 20
    c.Shape.Top = c.Parent.Top + 20
  Next c
End Sub

Position des commentaires

Sub PositionComments()
  For Each c In ActiveSheet.Comments
    c.Shape.Top = c.Parent.Top + 10
    c.Shape.Left = c.Parent.Offset(0, 1).Left + 10
  Next
End Sub

Affiche le commentaire à la position choisie

Dim m
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If m <> "" Then Range(m).Comment.Visible = False
    If Not Target.Comment Is Nothing Then
    Target.Comment.Visible = True
    Target.Comment.Shape.Top = Target.Top + 20
    Target.Comment.Shape.Left = Target.Left + 20
    Target.Comment.Shape.Height = 40
    Target.Comment.Shape.Width = 70
    m = Target.Address
  Else
   m = ""
  End If
End Sub

Saisie d'un commentaire avec la date du jour sur double-clic

- Commentaire date jour -

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Comment Is Nothing Then
    SendKeys "%Ia"
    SendKeys CStr(Now) & Chr(10)
    Cancel = True
  End If
End Sub

Saisie d'un commentaire personnalisé sur double-clic

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Comment Is Nothing Then
   With Target
     .AddComment ' Création commentaire
     .Comment.Shape.Width = 241.5
     .Comment.Shape.Height = 99.75
   End With
   SendKeys "%im"
   SendKeys "Lieu:" & Chr(10)
   Cancel = True
  End If
End Sub

Modification commentaire sur clic dans la cellule

CommentaireModif

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Target.Comment Is Nothing Then
     SendKeys "%IM{left}"
  End If
End Sub

Insère la date du jour et le nom d'utilsateur sur le clic droit

CommentaireDateHeure

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Comment Is Nothing Then
    Target.AddComment
    Target.Comment.Text Text:=CStr(Now) & Chr(10) & Environ("username") & Chr(10)
    lg = Len(Target.Comment.Text)
    With Target.Comment.Shape.TextFrame
      .Characters(Start:=1, Length:=lg).Font.Name = "Verdana"
      .Characters(Start:=1, Length:=lg).Font.Size = 8
      .Characters(Start:=1, Length:=lg).Font.Bold = True
      .Characters(Start:=1, Length:=lg).Font.Italic = True
      .Characters(Start:=1, Length:=lg).Font.ColorIndex = 3
      .Characters(Start:=lg, Length:=99).Font.Bold = False
      .Characters(Start:=lg, Length:=99).Font.Italic = False
      .Characters(Start:=lg, Length:=99).Font.ColorIndex = 1
    End With
    SendKeys "m"
  Else
    SendKeys "m"
  End If
End Sub

Date de saisie en commentaire

La date de saisie de chaque cellule est placée dans le commentaire de celle ci.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 3 And Target.Count = 1 Then ' colonne 3 seulement
    If Target.Comment Is Nothing Then Target.AddComment
    Target.Comment.Text Text:=Format(Date, "dd/mm/yy")
    Target.Comment.Shape.TextFrame.AutoSize = True
  End If
End Sub

Pour colorier les cellules pour ayant une date de saisie >30 jours

Sub colorie()
  For Each c In Sheets("feuil1").Comments
    c.Parent.Interior.ColorIndex = IIf(Date - CDate(c.Text) > 30, 3, xlNone)
  Next c
End Sub

Saisie d'un commentaire sans le nom de user sur double-clic

CommentaireSansNomUser

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Comment Is Nothing Then
     Target.AddComment ' Création commentaire
     Target.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
     Target.Comment.Shape.OLEFormat.Object.Font.Size = 7
     Target.Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
     SendKeys "+{F2}"
  End If
  Cancel = True
End Sub

Avec la date du jour

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Comment Is Nothing Then
   Target.AddComment ' Création commentaire
   Target.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
   Target.Comment.Shape.OLEFormat.Object.Font.Size = 7
   Target.Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
   Target.Comment.Text Text:=CStr(Date)
   SendKeys "+{F2}" & Chr(10)
  End If
  Cancel = True
End Sub

Pour obtenir une texture

Target.Comment.Shape.Fill.PresetTextured msoTextureBlueTissuePaper

Barre d'outils commentaire sans nom de User

Permet d'insérer un commentaire sans nom de User.
La barre d'outils peut être utilisée pour tous les classeurs(Masquer le classeur avec Fenêtre/Masquer).

BarreOutilsCommentaireSansNomUser

Sub auto_open()
  Dim barre As CommandBar
  Dim bouton As CommandBarControl
  On Error Resume Next
  Set barre = CommandBars.Add(Name:="BarreCommentaires")
  barre.Visible = True
  Set bouton = CommandBars("BarreCommentaires").Controls.Add(Type:=msoControlButton)
  bouton.Style = msoButtonCaption
  bouton.OnAction = "Commentaire"
  bouton.Caption = "Insère commentaire"
End Sub

Sub Commentaire()
  If ActiveCell.Comment Is Nothing Then
    ActiveCell.AddComment ' Création commentaire
    ActiveCell.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
    ActiveCell.Comment.Shape.OLEFormat.Object.Font.Size = 7
    ActiveCell.Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
    SendKeys "+{F2}"
  End If
End Sub

Commentaire en B10 visible si B10>B1

CmtAffiche

Private Sub Worksheet_Calculate()
  [B10].Comment.Visible = ([B10] > [B1])
End Sub

Interdit la saisie de commentaires sur une feuille protégée

CommentaireProtection

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = ActiveSheet.ProtectContents
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Application.CommandBars("Worksheet Menu Bar").Controls("Insertion").Controls("Commentaire").Enabled = _
     Not ActiveSheet.ProtectContents
End Sub

Sub auto_close()
    Application.CommandBars("Worksheet Menu Bar").Controls("Insertion").Controls("Commentaire").Enabled = True
End Sub

Fonction de clônage de commentaire

Si on modifie le commentaire en Feuil1, il est modifié dans une autre feuille

Fonction CloneComment
Fonction CloneComment + Valeur
Fonction CloneComment + Valeur + couleur cellule
Récupération du format des commentaires d'autres cellules

Fonction d'affichage d'un message dans un commentaire

La MFC classique permet de modifier la couleur mais ne permet pas d'afficher des messages.
La fonction AfficheCmt(cel, condition, msg, coul) en B3 crée un commentaire en A3 si A3 dépasse la valeur en B1.

FonctionAfficheCmt
FonctionAfficheCmt2
FonctionAfficheCmt3
FonctionAfficheCmt4

La condition doit être spécifiée entre ().

Function AfficheCmt(cel, cond, msg, coul)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  If Not cel.Comment Is Nothing Then cel.Comment.Delete
  If cond Then
    With cel
      If .Comment Is Nothing Then .AddComment
       .Comment.Shape.Width = Len(msg) * 6
       .Comment.Shape.Height = 10
       .Comment.Shape.Left = .Left + .Width + 5
       .Comment.Shape.Top = .Top - 2
       .Comment.Visible = True
       .Comment.Text Text:=msg
       .Comment.Shape.Fill.ForeColor.SchemeColor = coul
     End With
   End If
   AfficheCmt = ""
End Function

La fonction AfficheCmt(cel, condition, msg, coul) en B12 crée un commentaire en B11 si B11 dépasse la valeur en B2.

La condition peut être une expression complexe

Sur cet exemple, les caractères accentués ne sont pas autorisés.

En B2:
=Affichecmt(A2;(SOMMEPROD((A2<>"")*(ESTERREUR(CHERCHE(STXT(A2;LIGNE(INDIRECT("1:"&NBCAR(A2)));1);"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz @-_.0123456789"))))
);"Caractère invalide";2)

La fonction afficheCmtMax(champ) crée un commentaire dans la cellule qui contient le maximum d'un champ.

FonctionCommentaireMax

Function afficheCmtMax(champ)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  For Each c In champ
    If Not c.Comment Is Nothing Then c.Comment.Delete
  Next c
  lig = champ.Row + Application.Match(Application.Max(champ), champ, 0) - 1
  col = champ.Column
  With f.Cells(lig, col)
   If .Comment Is Nothing Then .AddComment
   .Comment.Shape.Width = 32
   .Comment.Shape.Height = 10
   .Comment.Shape.Left = .Left + .Width + 5
   .Comment.Shape.Top = .Top - 5
   .Comment.Visible = True
   Select Case Application.Max(champ)
     Case 0 To 30
       msg = "Bof"
       coul = 2
    Case 31 To 50
       msg = "ok"
       coul = 7
    Case Is > 50
       msg = "Bravo!"
       coul = 5
   End Select
   .Comment.Text Text:=msg
   .Comment.Shape.Fill.ForeColor.SchemeColor = coul
  End With
  afficheCmtMax = ""
End Function

Affichage en commentaire (info-bulle) du contenu d'une cellule

Au survol de A3, on voit en commentaire le contenu de la cellule F4.

=affichecmt(A3;VRAI;"Total F4: " &F4;3)

Affiche Info-bulle Cmt
Affiche Info-bulle Cmt2

Function AfficheCmt(cel, cond, msg, coul)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  If Not cel.Comment Is Nothing Then cel.Comment.Delete
  If cond Then
    With cel
      If .Comment Is Nothing Then .AddComment
      .Comment.Shape.Width = Len(msg) * 7
      .Comment.Shape.Height = 12
      .Comment.Shape.Left = .Left + .Width + 5
      .Comment.Shape.Top = .Top - 2
      .Comment.Visible = True
       tmp = CStr(msg)
      .Comment.Text Text:=tmp
      .Comment.Shape.Fill.ForeColor.SchemeColor = coul
      .Comment.Visible = False
     End With
   End If
   AfficheCmt = ""
End Function

Affiche une image en commentaire dans la cellule où la fonction est écrite

Sur l'exemple on affiche en C4 la photo spécifiée en A4 avec une fonction personalisée =AfficheCmtPhoto(NomPhoto;RépertoirePhoto;echelle)

En C4: =AfficheCmtPhoto(A4;"c:\mesdoc\";0,5)

Les images sont dans c:\mesdoc\

AffichePhotoCmt

Function AfficheCmtPhoto(nom, répertoire, Optional ech)
  Application.Volatile
  If IsMissing(ech) Then ech = 1
  Set f = Sheets(Application.Caller.Parent.Name)
  Set cel = Application.Caller
  If Not cel.Comment Is Nothing Then cel.Comment.Delete
  If nom <> "" Then
    With f.Range(cel.Address)
      If Dir(répertoire & nom & ".jpg") <> "" Then
      .AddComment
      .Comment.Shape.Left = .Left
      .Comment.Shape.Top = .Top
      .Comment.Visible = True
      .Comment.Text Text:=" "
      .Comment.Shape.Fill.UserPicture répertoire & nom & ".jpg"
      Set myShell = CreateObject("Shell.Application")
      If TypeName(répertoire) = "Range" Then
        Set myFolder = myShell.Namespace(répertoire.Value)
      Else
        Set myFolder = myShell.Namespace(répertoire)
      End If
      Set myFile = myFolder.Items.Item(nom & ".jpg")
      Taille = myFolder.GetDetailsOf(myFile, 26)
      .Comment.Shape.Height = Val(Split(Taille, "x")(1))
      .Comment.Shape.Width = Val(Split(Taille, "x")(0))
      .Comment.Shape.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
      .Comment.Shape.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
     End If
   End With
 End If
 AfficheCmtPhoto = ""
End Function

Affiche une photo dans un commentaire dans la cellule qui contient le maximum d'un champ

Les photos doivent être dans le même répertoire que le classeur.

FonctionCommentaireMaxPhoto

Function AfficheCmtPhotoMax(champ As Range, champNom As Range)
  Application.Volatile
  Set f = Sheets(Application.Caller.Parent.Name)
  For Each c In champ
     If Not c.Comment Is Nothing Then c.Comment.Delete
  Next c
  lig = champ.Row + Application.Match(Application.Max(champ), champ, 0) - 1
  col = champ.Column
  With f.Cells(lig, col)
    If .Comment Is Nothing Then .AddComment
    répertoire = ThisWorkbook.Path & "\"
    nom = champNom(Application.Match(Application.Max(champ), champ, 0))
    If Dir(répertoire & nom & ".jpg") <> "" Then
      .Comment.Shape.Left = .Left + .Width + 5
      .Comment.Shape.Top = .Top - 5
      .Comment.Visible = True
      .Comment.Text Text:=" "
      .Comment.Shape.Fill.UserPicture répertoire & nom & ".jpg"
      .Comment.Shape.Height = 30
      .Comment.Shape.Width = 30
      .Comment.Shape.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft
     End If
   End With
   AfficheCmtPhotoMax = ""
End Function

Fonction d'affichage d'un message d'alerte dans un commentaire

La fonction Réappro(cellule;Seuil) crée un commentaire si le stock atteint un seuil d'alerte.

En B14: =Réappro(B12;200)

FonctionCommentaire

Function Réappro(c, seuil)
  Application.Volatile
  With c
    If .Value < seuil Then
      If .Comment Is Nothing Then .AddComment
        .Comment.Text Text:="Alerte! " & vbLf & "Réappro:" & seuil - .Value
        .Comment.Shape.Fill.ForeColor.SchemeColor = 2
        .Comment.Shape.Width = 55
        .Comment.Shape.Height = 25
        .Comment.Shape.Left = .Left + 5
        .Comment.Shape.Top = .Top + 20
        .Comment.Visible = True
      Else
        If Not .Comment Is Nothing Then .Comment.Delete
      End If
    End With
End Function

Commentaire protégé

Pour la cellule A1, seul l'utilisateur Boisgontier est autorisé à le modifier.

CommentaireProtégé

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Address = "$A$1" And Not Target.Comment Is Nothing Then
      If InStr(Target.Comment.Text, Environ("username")) = 0 Then
         MsgBox "Vous n'êtes pas pas autorisé!"
         Exit Sub
      End If
   End If
End Sub

Commentaire dynamique

Le commentaire est le contenu de la cellule A2 de feuil1

CommentDyn

Private Sub Worksheet_Activate()
  With Range("B2")
    If .Comment Is Nothing Then Range("B2").AddComment
       .Comment.Text Text:=Sheets("Feuil1").[A2].Value
       .Comment.Shape.TextFrame.AutoSize = True
    End With
End Sub

Autre exemple

On récupère le libellé du produit de BD et on le met en commentaire dans l'onglet commande.

CommentaireBD2
CommentaireBD3

Private Sub Worksheet_Activate()
  maj
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  maj
End Sub

Sub maj()
  For Each c In [a2:a100]
    p = Application.Match(c, Application.Index([base], , 1), 0)
    If Not IsError(p) Then
       temp = Sheets("bd").Range("base").Cells(p, 2)
       If c.comment Is Nothing Then c.AddComment
       c.comment.Text Text:=temp
       c.comment.Shape.TextFrame.AutoSize = True
     End If
  Next c
End Sub

Autre exemple

Dans Feuil1, on récupère le commentaire de BD.

CommentaireBD

Code de feuil1

Private Sub Worksheet_Activate()
   maj
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect([A2:A10], Target) Is Nothing Then
      maj
   End If
End Sub

Sub maj()
   For Each c In [A2:A10]
      p = Application.Match(c, Application.Index([base], , 1), 0)
      If Not IsError(p) Then
         Sheets("BD").Range("BASE").Cells(p, 2).Copy
         c.Offset(0, 1).PasteSpecial Paste:=xlComments
      End If
   Next c
End Sub

Autre exemple

CommentaireDynamique

Les commentaires sont liés au contenu d'une autre cellule (dynamique)

-Sélectionner les cellules avec la touche Ctrl
-Bouton crée commentaire
- Pointer vers la cellule liée
- Lorsque le texte est modifié dans la cellule liée , il y a maj du commentaire
-Les cellules nommées peuvent être déplacées

-A l'impression (avec le bouton) les nos des commentaires sont affichés

Autorise les commentaires pour un seul utilisateur

Seul l'utilisateur réseau Boisgontier peut visualiser et modifier les commentaires - CommentBeforeRightClick -

Sub auto_open()
  If UCase(Environ("username")) = "BOISGONTIER" Then
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
  Else
    Application.DisplayCommentIndicator = xlNoIndicator
  End If
End Sub

Sub auto_close()
   Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Not Target.Comment Is Nothing And Not UCase(Environ("username")) = "BOISGONTIER" Then
     Cancel = True
  End If
End Sub

Photos en commentaire

Ajoute des photos en commentaire dans les cellules de la colonne A. Le nom de la photo doit être le même que le nom de la ville.

InserePhotosCommentaire
InserePhotosCommentaire2

Sub PhotoCommentaire2()
  répertoirePhotos = "c:\photos\" ' adapter
  ech = 1
  For Each c In Range("A2", [A65000].End(xlUp))
    c.ClearComments
    If Dir(répertoirePhotos & c & ".jpg") <> "" Then
       c.AddComment
       c.Comment.Text Text:=CStr(c.Value)
       c.Comment.Visible = True
       c.Comment.Shape.Fill.UserPicture répertoirePhotos & c.Value & ".jpg"
       Set myShell = CreateObject("Shell.Application")
       Set myFolder = myShell.Namespace(répertoirePhotos)
       Set myFile = myFolder.Items.Item(c & ".jpg")
       Taille = myFolder.GetDetailsOf(myFile, 26)
       c.Comment.Shape.Height = Val(Split(Taille, "x")(1))
       c.Comment.Shape.Width = Val(Split(Taille, "x")(0))
       c.Comment.Shape.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
       c.Comment.Shape.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
       c.Comment.Visible = False
     End If
   Next c
End Sub

Photos en commentaire dès la saisie

Ajoute des photos en commentaire dans les cellules de la colonne A dès la saisie du nom de la ville.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    répertoirePhoto = "c:\photos\" ' adapter
    ech = 1
    Target.ClearComments
    nf = répertoirePhoto & Target & ".jpg"
    If Dir(nf) <> "" Then
       Target.AddComment
       Target.Comment.Text Text:=CStr(Target.Value)
       Target.Comment.Visible = True
       Target.Comment.Shape.Fill.UserPicture nf
       Set myShell = CreateObject("Shell.Application")
       Set myFolder = myShell.Namespace(répertoirePhoto)
       Set myFile = myFolder.Items.Item(Target & ".jpg")
       Taille = myFolder.GetDetailsOf(myFile, 26)
       Target.Comment.Shape.Height = Val(Split(Taille, "x")(1))
       Target.Comment.Shape.Width = Val(Split(Taille, "x")(0))
       Target.Comment.Shape.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
       Target.Comment.Shape.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
       Target.Comment.Visible = False
     End If
   End If
End Sub

Insertion de photos dans un calendrier

CalendrierPhoto

Planning

A partir d'une BD, on crée un planning. Le détail d'une ligne apparaît en commentaire.

BDPlanComment

Sub planning()
Sheets("planning").[A5:BB20].ClearContents
Sheets("planning").[A5:BB20].Interior.ColorIndex = xlNone
Sheets("planning").[A5:BB20].Font.Bold = False
Sheets("planning").[A5:BB20].ClearComments
Sheets("BD").Select
[A2].Select
ligne = 5
Do While ActiveCell <> ""
mcible = ActiveCell
Sheets("planning").Cells(ligne, 1).Value = ActiveCell
Do While mcible = ActiveCell
mtitreAction = ActiveCell.Offset(0, 1)
semaine = ActiveCell.Offset(0, 2)
If Sheets("planning").Cells(ligne, semaine + 1) <> "" Then ligne = ligne + 1
Sheets("planning").Cells(ligne, semaine + 1).Value = mtitreAction
'--
lg = Len(mtitreAction)
'--
p = Application.Match(ActiveCell.Offset(0, 6), Sheets("planning").[A2:F2], 0)
If Not IsError(p) Then coul = Sheets("planning").[A2].Offset(0, p).Interior.ColorIndex
Sheets("planning").Cells(ligne, semaine + 1).Interior.ColorIndex = coul
'--
With Sheets("planning").Cells(ligne, semaine + 1)
.AddComment ' Création commentaire
.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
.Comment.Shape.OLEFormat.Object.Font.Size = 7
.Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
Commentaire = "Offre:" & ActiveCell.Offset(0, 7) & Chr(10)
déb = Len(Commentaire)
Commentaire = Commentaire & "Support:" & ActiveCell.Offset(0, 6) & Chr(10)
déb2 = Len(Commentaire)
Commentaire = Commentaire & "Budget:" & ActiveCell.Offset(0, 5) & Chr(10)
.Comment.Text Text:=Commentaire
.Comment.Shape.TextFrame.Characters(Start:=1, Length:=6).Font.Bold = True
.Comment.Shape.TextFrame.Characters(Start:=déb, Length:=9).Font.Bold = True
.Comment.Shape.TextFrame.Characters(Start:=déb2, Length:=7).Font.Bold = True
.Comment.Visible = False
End With
ActiveCell.Offset(1, 0).Select
Loop
ligne = ligne + 1
Loop
Sheets("planning").Select
[A2].Select
End Sub

Place des photos en commentaire

CmtPhoto

Sub PhotoCommentaire()
  répertoirePhotos = "c:\photos\"
  For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
     If Dir(répertoirePhotos & c & ".jpg") <> "" Then
        c.ClearComments
        c.AddComment
        c.Comment.Text Text:=c.Value
        c.Comment.Shape.Fill.UserPicture répertoirePhotos & c & ".jpg"
        c.Comment.Shape.Height = 50
        c.Comment.Shape.Width = 50
        c.Comment.Shape.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft
        c.Comment.Shape.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
     End If
  Next
End Sub

Calendrier en commentaire

CalendrierCommentaire

Sub CalendrierCommentaire()
  répertoire = ThisWorkbook.Path & "\"
  For m = 1 To 12
    [n5] = m
    With ActiveSheet
      [C1:I7].CopyPicture
      .ChartObjects.Add(50, 0, [C1:I7].Width, [C1:I7].Height).Chart.Paste
      .ChartObjects(1).Chart.Export Filename:=répertoire & "monimage.gif", FilterName:="gif"
      .ChartObjects(1).Delete
     End With
     With ActiveSheet.Range("A1").Offset(m - 1, 0)
       .ClearComments
       .AddComment
       .Comment.Shape.Fill.UserPicture répertoire & "Monimage.gif"
       .Comment.Shape.Height = 74.25
       .Comment.Shape.Width = 125.25
       .Comment.Visible = False
     End With
   Next m
End Sub

Graphe en commentaire

Copie un graphique en commentaire pour chaque produit.

CommentaireGraphe

Sub grapheCommentaire()
For y = 2 To [A65000].End(xlUp).Row
ActiveSheet.Cells(y, 1).Select
ActiveSheet.ChartObjects(1).Activate
ActiveChart.SeriesCollection(1).Formula = _
"=SERIES(" & ActiveSheet.Name & "!R" & y & _
"C1," & ActiveSheet.Name & "!R1C2:R1C4," & ActiveSheet.Name & "!R" & y & "C2:R" & y & "C4,1)"

ActiveSheet.ChartObjects(1).Chart.Export Filename:= _
"graphe.gif", FilterName:="GIF"
With ActiveSheet.Cells(y, 1)
On Error Resume Next
.AddComment
On Error GoTo 0
.Comment.Shape.Height = 110
.Comment.Shape.Width = 140
.Comment.Shape.Fill.UserPicture "Graphe.gif"
End With
Next y
End Sub

Modifier la forme des commentaires

CmtForme

Sub CreeShapes()
  i = 1
  For Each c In ActiveSheet.Comments
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeCross, _
       Left:=c.Parent.Left + c.Parent.Width - 9, Top:=c.Parent.Top, Width:=9, Height:=9)
      .Fill.ForeColor.RGB = RGB(255, 255, 255)
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .Name = "commentaire" & i
    i = i + 1
   End With
  Next
End Sub

Sub SupShapes()
   For Each s In ActiveSheet.Shapes
     If Left(s.Name, 11) = "commentaire" Then s.Delete
   Next s
End Sub

Commentaires avec triangle vert

Pour faire apparaître les commentaires avec un triangle vert sur un champ.

TriangleVert

Sub CreeShapes()
  Set plage = [A1:D10] 'adapter
  SupShapes
  For Each c In ActiveSheet.Comments
    If Not Intersect(plage, Range(c.Parent.Address)) Is Nothing Then
      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
        Left:=c.Parent.Left + c.Parent.Width - 4, Top:=c.Parent.Top + 1, Width:=4, Height:=4)
        .Fill.ForeColor.RGB = RGB(0, 255,0)
        .Line.ForeColor.RGB = RGB(0, 255,0)
        .IncrementRotation 180
        .Name = "commentaire" & c.Parent.Address
     End With
   End If
  Next
End Sub

Sub SupShapes()
  For Each s In ActiveSheet.Shapes
    If Left(s.Name, 11) = "commentaire" Then s.Delete
  Next s
End Sub

Forme commentaire en fonction du User

Fonctionne sur double-clic

-CommentaireFormeUser -

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Comment Is Nothing Then
    If Environ("username") = "Boisgontier" Then
      forme = msoShapeCross
      taille = 9
      cfond = RGB(255, 255, 255)
      ctrait = RGB(255, 0, 0)
    Else
      forme = msoShapeRectangle
      taille = 5
      cfond = RGB(0, 255, 0)
      ctrait = RGB(0, 255, 0)
    End If
    Target.AddComment
    Target.Comment.Shape.OLEFormat.Object.Font.Name = "Tverdana"
    Target.Comment.Shape.OLEFormat.Object.Font.Size = 7
    Target.Comment.Shape.OLEFormat.Object.Font.FontStyle = "Normal"
    With ActiveSheet.Shapes.AddShape(Type:=forme, _
       Left:=Target.Left + Target.Width - taille, Top:=Target.Top, Width:=taille, Height:=taille)
      .Fill.ForeColor.RGB = cfond
      .Line.ForeColor.RGB = ctrait
    End With
    SendKeys "+{F2}"
    Cancel = True
  Else
     For Each s In ActiveSheet.Shapes
       If Not Intersect(s.TopLeftCell, Target) Is Nothing Then
         On Error Resume Next
         Target.Comment.Delete
         s.Delete
       End If
    Next s
    Cancel = True
   End If
End Sub

Impression des indicateurs de commentaire

CommentaireImprime

Sub Imprime()
  CreeShapesCommentaires
  ActiveWindow.SelectedSheets.PrintPreview
  SupShapes
End Sub

Sub CreeShapesCommentaires()
  i = 1
  For Each c In ActiveSheet.Comments
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
       Left:=c.Parent.Left + c.Parent.Width - 4, Top:=c.Parent.Top + 1, Width:=4, Height:=4)
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .IncrementRotation 180
        .Name = "commentaire" & i
        i = i + 1
      End With
  Next
End Sub

Sub SupShapes()
  For Each s In ActiveSheet.Shapes
     If Left(s.Name, 11) = "commentaire" Then s.Delete
  Next s
End Sub

Autre version

On affiche l'adresse des cellules commentaire dans des textbox

Sub Imprime2()
CreeShapesCommentaires2
ActiveWindow.SelectedSheets.PrintPreview
SupShapes
End Sub

Sub SupShapes()
For Each s In ActiveSheet.Shapes
If Left(s.Name, 11) = "commentaire" Then s.Delete
Next s
End Sub

Sub CreeShapesCommentaires2()
i = 1
For Each c In ActiveSheet.Comments
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, c.Parent.Left + c.Parent.Width - 15, _
c.Parent.Top , 15, 7).Name = "commentaire" & i
With ActiveSheet.Shapes("commentaire" & i)
.TextFrame.Characters.Text = Replace(c.Parent.Address, "$", "")
.Fill.ForeColor.SchemeColor = 13
.TextFrame.Characters.Font.Size = 5
End With
i = i + 1
Next
End Sub

Cache les triangles rouges de commentaire
Modifier la couleur des triangles rouges de commentaire

Commentaire Cache
Commentaire Cache CelluleActive Double-clic
Commentaire Cache CelluleActive >100
Commentaire Cache CelluleActive >100 B3

Sub CreeShapesBlancs()
  SupShapes
  i = 1
  For Each c In ActiveSheet.Comments
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
       Left:=c.Parent.Left + c.Parent.Width - 4, Top:=c.Parent.Top + 1, Width:=4, Height:=4)
      .Fill.ForeColor.RGB = RGB(255, 255, 255)
      .Line.ForeColor.RGB = RGB(255, 255, 255)
      .IncrementRotation 180
      .Name = "commentaire" & i
      i = i + 1
   End With
 Next
End Sub

Sub SupShapes()
  For Each s In ActiveSheet.Shapes
    If Left(s.Name, 11) = "commentaire" Then s.Delete
  Next s
End Sub

Pour mettre en vert les commentaires

Sub CreeShapesCouleurVert()
  i = 1
  For Each c In ActiveSheet.Comments
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
     Left:=c.Parent.Left + c.Parent.Width - 4, Top:=c.Parent.Top + 1, Width:=4, Height:=4)
     .Fill.ForeColor.RGB = RGB(0, 255, 0)
     .Line.ForeColor.RGB = RGB(0, 255, 0)
     .IncrementRotation 180
     .Name = "commentaire" & i
     i = i + 1
    End With  
  Next
End Sub

Commentaire d'aide à la saisie en colonne C

Un commentaire d'aide est affiché lors de la sélection d'une cellule puis supprimé.

CommentAide

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 3 And Target.Count = 1 Then
    On Error Resume Next
    If [mémo] <> "" Then Range([mémo]).Comment.Delete
    Range("A1").Copy
    Target.PasteSpecial Paste:=xlPasteComments
    ActiveWorkbook.Names.Add Name:="mémo", RefersToR1C1:="=" & Chr(34) & Target.Address & Chr(34)
  Else
    On Error Resume Next
    If [mémo] <> "" Then
      Range([mémo]).Comment.Delete
      ActiveWorkbook.Names("mémo").Delete
    End If
  End If
End Sub

Récupère les commentaires des cellules référencées dans une autre feuille

CommentaireDynamique

Private Sub Worksheet_Activate()
  For Each c In ActiveSheet.Comments
    If Not c.Parent.Formula Like "*[+-/~*^]*" Then
      a = Split(Mid(c.Parent.Formula, 2), "!")
      If UBound(a) = 0 Then
         Range(a(0)).Copy
      Else
         Sheets(a(0)).Range(a(1)).Copy
      End If
      c.Parent.PasteSpecial Paste:=xlComments
      c.Parent.PasteSpecial Paste:=xlFormats
    End If
  Next c
End Sub

Edition d'une fiche avec récupération du commentaire

CommentaireEditionFiche

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    Set result = [bd].Find(what:=[B2])
    If Not result Is Nothing Then
      ligne = result.Row
      Sheets("BD").Cells(ligne, "A").Copy
      With Range("B11")
        .PasteSpecial Paste:=xlPasteComments
        .Comment.Visible = True
        .Comment.Shape.Select True
      End With
      Selection.ShapeRange.IncrementLeft -81#
      Selection.ShapeRange.IncrementTop 1.5
      Target.Select
    End If
  End If
End Sub

MFC sur commentaire

Colorie les cellules contenant un commentaire

=EstCommentaire(A2)

Dans un module:

Function EstCommentaire(c)
  Application.Volatile
  EstCommentaire = Not c.Comment Is Nothing
End Function

Met en gras les cellules contenant ok dans le commentaire.

MFC:=ESTNUM(CHERCHE("OK";comment(A2)))

Dans un module:

Function Comment(c)
  Application.Volatile
  If c.Comment Is Nothing Then
     Comment = ""
  Else
     Comment = Replace(c.Comment.Text, Chr(10), "")
  End If
End Function

Filtre les lignes avec commentaires

FiltreCommentaire

Sub filtreComment()
  Range("b2:B" & [B65000].End(xlUp).Row).EntireRow.Hidden = True
  [B:B].SpecialCells(xlCellTypeComments).EntireRow.Hidden = False
End Sub

Sub tout()
  Rows.Hidden = False
End Sub

Commentaires invisibles au survol

Commentaire survol
CommentaireChampsurvol

Saisie d'un commentaire avec Input

SaisieCommentInput
CommentaireSaisieForm

Tri de commentaires

TriComment

Commentaire partagé

Un commentaire de cellule est partagé entre plusieurs utilisateurs.
Chaque utilisateur ne peut modifier que sa partie.

Commentaire partagé

Private Sub UserForm_Initialize()
  If Not ActiveCell.Comment Is Nothing Then
    p1 = InStr(ActiveCell.NoteText, Environ("username"))
    If p1 > 0 Then
      p1 = p1 + Len(Environ("username")) + 1
      p2 = InStr(p1, ActiveCell.NoteText, Chr(169))
      UserForm1.TextBox1 = Mid(ActiveCell.NoteText, p1 + 1, p2 - p1 - 1)
    End If
  End If
  Me.Left = 300
  Me.Top = 100
End Sub

Private Sub B_Ok_Click()
  If ActiveCell.Comment Is Nothing Then
     ActiveCell.AddComment
     temp = "[" & Environ("username") & "]" & Chr(10) & _
     Replace(Me.TextBox1, Chr(13), "") & Chr(169) & Now() & Chr(10)
   Else
     p1 = InStr(ActiveCell.NoteText, Environ("username"))
     If p1 > 0 Then
       p1 = p1 + Len(Environ("username"))
       p2 = InStr(p1, ActiveCell.NoteText, Chr(169))
       temp = Left(ActiveCell.NoteText, p1 + 1) & Replace(Me.TextBox1, Chr(13), "") & _
       Mid(ActiveCell.NoteText, p2)
     Else
       temp = ActiveCell.NoteText & "[" & Environ("username") & "]" & Chr(10) & _
       Replace(Me.TextBox1, Chr(13), "") & Chr(169) & Now() & Chr(10)
     End If
   End If
   '-- nom en gras
   With ActiveCell
     .Comment.Text Text:=temp
     .Comment.Visible = True
     .Comment.Shape.Select
     Selection.AutoSize = True
     .Comment.Visible = False
     pd1 = 1
     pd2 = 1
     Do While InStr(pd1, .NoteText, "[")
       p1 = InStr(pd1, .NoteText, "[")
       p2 = InStr(pd2, .NoteText, "]")
       .Comment.Shape.TextFrame.Characters(Start:=p1, Length:=999).Font.Bold = False
       .Comment.Shape.TextFrame.Characters(Start:=p1, Length:=p2 - p1 + 1).Font.Bold = True
       pd1 = p1 + 1
       pd2 = p2 + 1
     Loop
   End With
   Unload Me
End Sub

Commentaire propriétaire

On ne peut modifier ou supprimer que les commentaires que l'on a crée.

Comment propriétaire

Copie d'un champ dans un commentaire

Comment copie champ

Sub CopieChamp()
  With ActiveSheet.Range("A1")
    If Not .Comment Is Nothing Then .Comment.Delete
  End With
  repertoire = ThisWorkbook.Path & "\"
  fichier = "monimage.jpg"
  With ActiveSheet
     .[E1:I5].CopyPicture
     .Paste Destination:=.Range("A1") 'crée un shape
     Set s = .Shapes(.Shapes.Count)
     s.CopyPicture
    .ChartObjects.Add(0, 0, s.Width, s.Height * 1.2).Chart.Paste
    .ChartObjects(1).Chart.Export Filename:=repertoire & fichier, FilterName:="jpg"
    .Shapes(.Shapes.Count).Delete
    .Shapes(.Shapes.Count).Delete
  End With
  With ActiveSheet.Range("A1")
    .AddComment
    ech = 1
    .Comment.Shape.Fill.UserPicture repertoire & fichier
    .Comment.Shape.ScaleHeight ech, msoFalse, msoScaleFromTopLeft
    .Comment.Shape.ScaleWidth ech, msoFalse, msoScaleFromTopLeft
  End With
End Sub

Récupération d'un commentaire image

Comment image récup

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$3" Then
    Application.EnableEvents = False
    p = Application.Match(Target, [listeNoms], 0)
    Sheets("photoscommentaire").[A2].Offset(p - 1, 0).Copy
    Target.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone
    Application.EnableEvents = False
  End If
End Sub

Commentaire structuré

CommentaireStructuré

Private Sub b_ok_Click()
  n = 3
  Dim pos(), lg()
  ReDim pos(n), lg(n)
  poscourant = 1
  For i = 1 To n
    temp = temp & Me("label" & i) & ":" & Me("textbox" & i) & vbLf
    pos(i) = poscourant
    poscourant = poscourant + Len(Me("label" & i)) + Len(Me("textbox" & i)) + 2
    lg(i) = Len(Me("label" & i))
  Next i
  With ActiveCell
    If Not .Comment Is Nothing Then .Comment.Delete
    .AddComment
    .Comment.Text Text:=temp
    For i = 1 To n
      .Comment.Shape.TextFrame.Characters(Start:=pos(i), Length:=lg(i)).Font.Bold = True
    Next i
   .Comment.Visible = True
   .Comment.Shape.TextFrame.AutoSize = True
   .Comment.Visible = False
  End With
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  If Not ActiveCell.Comment Is Nothing Then
    temp = ActiveCell.Comment.Text
    a = Split(temp, vbLf)
    For i = LBound(a) To UBound(a)
      p = InStr(a(i), ":")
      If p > 0 Then Me("textbox" & i + 1) = Mid(a(i), p + 1)
    Next i
  End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  UserForm1.Top = Target.Top + 40 - Cells(ActiveWindow.ScrollRow, 1).Top
  UserForm1.Left = 150
  UserForm1.Show
  Cancel = True
End Sub

Saisie d'un commentaire dans un formulaire sur clic-droit

CommentaireSaisieForm
CommentaireSaisieForrm Feuille protégée

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  UserForm1.Top = Target.Top + 40 - Cells(ActiveWindow.ScrollRow, 1).Top
  UserForm1.Left = 150
  UserForm1.Show
  Cancel = True
End Sub

Private Sub B_Ok_Click()
  With ActiveCell
    If .Comment Is Nothing Then .AddComment
       .Comment.Text Text:=Replace(Me.TextBox1, Chr(13), "")
       .Comment.Visible = True
       .Comment.Shape.TextFrame.AutoSize = True
       .Comment.Visible = False
    End With
    Unload Me
End Sub

Private Sub UserForm_Initialize()
   If ActiveCell.Comment Is Nothing Then
     UserForm1.TextBox1 = Now & Chr(10) & Environ("username") & Chr(10)
   Else
     UserForm1.TextBox1 = ActiveCell.Comment.Text
   End If
End Sub

Noms de champ d'une feuille en commentaire

Affiche les noms de champ de la feuille en commentaire.

NomsChampCmt
BarreNomsChamps

Sub NomsChampsCmt()
  For Each n In ActiveWorkbook.Names
    p = InStr(n, ActiveSheet.Name)
    If p > 0 Then
       p1 = InStr(n, "!")
       p2 = InStr(n, ":")
       If p2 > 0 Then
          c = Mid(n, p1 + 1, p2 - p1 - 1)
       Else
         c = n
       End If
       If Not Range(c).Comment Is Nothing Then Range(c).Comment.Delete
       Range(c).AddComment n.Name & ":" & n
       With Range(c).Comment.Shape.OLEFormat.Object.Font
         .Name = "Tverdana"
         .Size = 8
         .FontStyle = "Normal"
         .ColorIndex = 0
       End With
       Range(c).Comment.Visible = True
       Range(c).Comment.Shape.TextFrame.AutoSize = True
     End If
   Next n
End Sub

Affiche les formules du champ sélectionné en commentaire

CmtFormules
BarreFormules.xls

Sub AfficheFormuleCmt()
   For Each c In Selection
      If c.HasFormula = True Then
        If Not c.Comment Is Nothing Then c.Comment.Delete
        c.AddComment c.Formula
        With c.Comment.Shape.OLEFormat.Object.Font
          .Name = "Tverdana"
          .Size = 8
          .FontStyle = "Normal"
          .ColorIndex = 0
        End With
        c.Comment.Visible = True
        c.Comment.Shape.TextFrame.AutoSize = True
     End If
   Next c
End Sub

Sub EffaceCmt()
On Error Resume Next
Selection.ClearComments
End Sub

Sub MasqueCmt()
On Error Resume Next
For Each c In ActiveSheet.Comments
c.Visible = False
Next c
End Sub

Sub AfficheCmt()
On Error Resume Next
For Each c In ActiveSheet.Comments
c.Visible = True
Next c
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

Faire apparaître en A10 le commentaire de la cellule A2

CommentCopie