Discussion :

[persjussysylvain]

Bonjour,

Voici un code qui me permet d'insérer les valeurs de cellules dans un commentaire d'une autre cellule

Je voudrais que ce commentaire reste à la même position même si je masque des lignes par la suite
J'ai une procédure qui met permet de masquer des lignes au clic droit sur certaines cellules et alors la position du commentaire se séplace.
Voir les images suivantes :

Bon positionnement des commentaires :


Commentaires déplacés suites à des lignes masquées


Voici mon code :

Option Explicit


Code pour masquer des lignes (pour info => fonctionne trés bien")

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Private Sub Worksheet_BeforeRightClick(ByVal R As Range, Cancel As Boolean)
  If Intersect(R, [B56:B191]) Is Nothing Or (R.Row - 2) Mod 9 Then Exit Sub
  Dim P As Range
  Cancel = True
  Set P = R(3, 1).Resize(7)
  P.EntireRow.Hidden = Not P.EntireRow.Hidden
  If P.EntireRow.Hidden = True Then Exit Sub
  R(4, 1).Resize(3).EntireRow.Hidden = True 'pour cacher
  R(9, 1).EntireRow.Hidden = True
End Sub

Code pour insérer des commentaires

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Cel As Range
    Dim Com As Comment
    Dim Chaine As String
    Dim Val1 As Integer
    Dim Val2 As Integer
 
    Val1 = 8: Val2 = 0
 
    If Target.Row < 56 Then Exit Sub 'seulement à partir de la ligne 56
    If Target.Count > 1 Then Exit Sub 'seulement une seule cellule
    If Target.Row Mod 9 <> Val1 And Target.Row Mod 9 <> Val2 Then Exit Sub
    If Target.Column > 390 Then Exit Sub 'seulement jusqu'à la colonne 390
 
    If Target.Row Mod 9 = Val1 Then Set Cel = Target.Offset(-6) Else Set Cel = Target.Offset(-7)
 
    With Cel
 
        Set Com = .Comment
 
        If Not Com Is Nothing Then Com.Delete
 
        If Target.Row Mod 9 = Val1 Then
 
            If Target.Value <> "" Then Chaine = Target.Value
            If Target.Offset(1).Value <> "" Then Chaine = Chaine & IIf(Target.Value <> "", vbCrLf & Target.Offset(1).Value, Target.Offset(1).Value)
 
        Else 'sinon, pour Val2
 
            If Target.Value <> "" Then Chaine = Target.Value
            If Target.Offset(-1).Value <> "" Then Chaine = Target.Offset(-1).Value & IIf(Target.Value <> "", vbCrLf & Chaine, "")
 
        End If
 
        If Chaine <> "" Then
 
            Set Com = .AddComment
            Com.Text Chaine
            Com.Shape.TextFrame.AutoSize = True
            Com.Visible = True '<--- le commentaire reste toujours affiché
 
        End If
 
    End With
 
End Sub

Ci-joint les 2 fichiers exemples correspondant aux images

En faisant un clic droit sur un commentaire et en sélectionnant "Format de commentaire" et "Propriétés" et "Déplacer sans dimensionner avec les cellules"
=> alors cela fonctionne mais ca ne marche que pour un commentaire à la fois et pas pour tout les commentaires.
Mais ca serait la meilleure solution si on peut mettre cette propriété pour tous les commentaires car je pourrais déplacer manuellement le commetaire si besoin et il resterait à cette place quand des lignes sont masquées ou affichées.
Est-il donc possible de mettre cette propriété pour tous les commentaires svp ?

Pouvez-vous m'aider svp ?

Je vous remercie


Cordialement

[ARTURO83]

Bonjour,

une proposition à adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Emplacement_commentaires()
    Application.ScreenUpdating = False
    For Each cell In Range("A56:NZ100") 'mettez votre plage
        AdrCell = cell.Address
        If Not cell.Comment Is Nothing Then
            If cell.Comment.Visible = False Then cell.Comment.Visible = True
            Range(AdrCell).Select
            cell.Comment.Shape.Select True
            With cell.Comment.Shape
                .Left = Range(AdrCell).Offset(0, 1).Left ' le commentaire se place à droite de la cellule
                .Top = Range(AdrCell).Offset(0, 1).Top 'le commentaire se place sur la même ligne que la cellule
            End With
        End If
    Next
End Sub

Cdlt

[persjussysylvain]

Ou dois-je ettre cette procédure

Je l'ai mise au même endroit que mon code
mais il me dit que Cell n'est pas défini? puis AdrCell n'est pas défini ?

[ARTURO83]

Dans un module standard
Pièce jointe 444843
Cliquez sur insertion, module et copiez le code

Ensuite 2 possibilités, soit vous appelez la macro à partir de votre code, ou bien vous créez un bouton sur votre feuille auquel vous y affectez cette macro.

[persjussysylvain]

Ca fonctionnai bien

Mais après plusieurs test il me note
La méthode Select de l'objet shape a échoué
Cell.Comment.Shape.Select True

Vous avez une idée de ce message svp ?

J'ai créé un bouton de commande

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub CommandButton1_Click()
Emplacement_commentaires
End Sub

Et j'avais appelé la procédure dans la procédure suivante comme ci dessous en rouge :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Worksheet_BeforeRightClick(ByVal R As Range, Cancel As Boolean)
  If Intersect(R, [B56:B191]) Is Nothing Or (R.Row - 2) Mod 9 Then Exit Sub
  Dim P As Range
  Cancel = True
  Set P = R(3, 1).Resize(7)
  P.EntireRow.Hidden = Not P.EntireRow.Hidden
Emplacement_commentaires
  If P.EntireRow.Hidden = True Then Exit Sub
  R(4, 1).Resize(3).EntireRow.Hidden = True 'pour cacher
  R(9, 1).EntireRow.Hidden = True
Emplacement_commentaires
 End Sub

Car quand je masquais les lignes, les commentaires ne se repositionnaient pas automatiquement
J'ai donc voulu essayer d'appeler la procédure à chaque clic droit pour repositionner les commentaires
et je pense que le bug est apparu à partir de ce moment

Merci de votre aide

[ARTURO83]

Bonjour,

Dans le module de la feuille:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub Worksheet_BeforeRightClick(ByVal R As Range, Cancel As Boolean)
    Application.EnableEvents = True
    If Intersect(R, [B56:B191]) Is Nothing Or (R.Row - 2) Mod 9 Then Exit Sub
    Dim P As Range
    Cancel = True
    Set P = R(3, 1).Resize(7)
    P.EntireRow.Hidden = Not P.EntireRow.Hidden
    If P.EntireRow.Hidden = True Then Exit Sub
    R(4, 1).Resize(3).EntireRow.Hidden = True 'pour cacher
    R(9, 1).EntireRow.Hidden = True
    Emplacement_commentaires
    Cancel = True
    Application.EnableEvents = False
End Sub

Dans un module standard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Emplacement_commentaires()
    Application.ScreenUpdating = False
    For Each cell In Range("E56:NS269") 'mettez votre plage
        AdrCell = cell.Address
        If Not cell.Comment Is Nothing Then
            If cell.Comment.Visible = False Then cell.Comment.Visible = True
            Range(AdrCell).Select
            cell.Comment.Shape.Select True
            With cell.Comment.Shape
                .Left = Range(AdrCell).Offset(0, 1).Left ' le commentaire se place à droite de la cellule
                .Top = Range(AdrCell).Offset(0, 1).Top 'le commentaire se place sur la même ligne que la cellule
            End With
        End If
    Next
End Sub

Cdlt