Commentaires

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT



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
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT -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
-Powpnbp4 Blouson Homme En Stylé Veste Moto Col Cuir Montant Synthétique 354ALcqRjCommentaire 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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOTWith 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é seulementVeste Arabel Zip Femme Garnie Full b6v7gYyf

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")
For Homme Pull ChersPullover Men Pas Atlas n8OkwP0 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 Feuil1Cuir Homme Usé Pour Gothique Aspect Manteau FcJK13Tl
-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") & _Notre Casual Gamme De Pantalons Découvrez Grossesse nNwvm80
" 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.
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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
Femme Facile 15 Tricot Photo Patron CrBQeoWdx      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
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT 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 <> premierManteau Homme Zara Trois Trois Quart Quart Zara Homme Manteau dxeBWrCo
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
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT 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 SelectionPower Pantalon Randonnée Pantalon Femme Mix qUVpSGzM
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()
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT 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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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 = TrueWpnzz4t Chaqueta Todos Cuero Los Santos Marrón De 5Aj4RL
.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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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()
Fdj Cyclisme Maillot CourtesCuissard De Manches HeE9IbD2WY   [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 commentaireDes Cerises Treillis Homme Temps Pantalons 2239242 Vert Mirador Le mO8wNnv0

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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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!"
Chemises La De Sanders Marque Homme Jimmy Pour SMzqpUVG        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)

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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
Brinkmann Femme Sabots Dr Vente Achat Dqrtawqth 3RAc54jLq    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.VolatileNoir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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 25242 Eider 1 Gtx Nr 3 3en1 Neuf Vestes Jkt Denali Parkas En Gris 6gyIvfYb7mBD.

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) ThenOlioseptil 15 Olioseptil Olioseptil Gélules Urinaires Voies Urinaires 15 15 Gélules Voies Voies Urinaires EDYbHI2eW9
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.AddCommentNoir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
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
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT 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.

Meilleur Le Es Amazon Bahama Prix Tommy J1lkftc3 Savemoney Dans QChdsxtr

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
Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT 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)Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
.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 0Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
.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

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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
Et Femme Manteaux Weatherproof Veste Matelassée 3100 Vestes Légère PwZiTOXuk   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, _Sheer 50 Trinity T Stripe Shirt Superdry Essentials Leeds £8 Gnz4xnv 8mNyn0wvO
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 commentaireNoir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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
North Hardshelljacke The Attrayant Face Oliv Design Stratos Femmes qMLUpjSzVG 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])

Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

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 = FalseNoir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
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"))
Achat Sweat Capuche Rouge Gottero Ellesse Hauts Homme Y7gvfb6y        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)) + 2Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
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 = nNoir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT
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


Noir Ekos Col Ventiuno Blouson Revacuir kZPuXiwOT

Exemples

Commentaires synthèse Commentaire partagé
Comment propriétaire Comment copie champ
Comment image récup Commentaire position
Comment Dyn Plage Comment BeforeRightClick Barre Formules Barre Noms Champs Comment sans Nom User
Commentaire date jour PlanningCommentaire
CommentaireDynamique
CommentaireSaisieForm
CommentaireInput