Autres Commentaire dans tous ces états

[VIARD]

Bonjour à tous

Je vous présente tous mes vœux pour cette nouvelle année, surtout de santé.
aussi à cette occasion, un petit utilitaire, à vous de voir.
Amicalement

Jean-Paul

 

[VIARD]

Bonjour à toutes et tous

J'ai repris légèrement le fichier pour améliorer.
Plus un fichier traitant uniquement, Cmt couleur.
Voici le code complet.

Sub Commentaire_Multi_Couleurs()
Dim cmt As Comment, i%
Dim txt(1 To 7) As String
Dim D(1 To 7) As Long
Dim F(1 To 7) As Long
Dim txt8$, Adr$
Dim R%, G%, B%
'----- c'est un essai laborieux en Excel2007

Adr = ActiveCell.Address
'----- Contrôle présence Adr & Adr2 -----
If Adr = "" Then
    MsgBox "adresse manquante"
    Exit Sub
End If
'-------- Cellules nommées Texte -------
'XXT1,XXT2,XXT3,XXT4,XXT5,XXT6,XXT7
'-------- Cellules nommées Couleurs ----
'Color1,Color2,Color3,Color4,Color5,Color6,Color7
'------- Choix Démo - Utilisateur ------
If Sheets("Feuil1").Range("A1") = 1 Then 'Démo
    txt(1) = "Frais établis ce jour: Période du:"
    txt(2) = " 5 Jan 2026"
    txt(3) = " au"
    txt(4) = " 24 Jan 2026"
    txt(5) = " Montant:"
    txt(6) = " 201.75"
    txt(7) = " €"
ElseIf Sheets("Feuil1").Range("A1") = 0 Then 'Utilisateur
    txt(1) = Range("XXT1").Text
    txt(2) = Chr(32) & Range("XXT2").Text
    txt(3) = Chr(32) & Range("XXT3").Text
    txt(4) = Chr(32) & Range("XXT4").Text
    txt(5) = Chr(32) & Range("XXT5").Text
    txt(6) = Chr(32) & Range("XXT6").Text
    txt(7) = Chr(32) & Range("XXT7").Text
ElseIf Sheets("Feuil1").Range("A1") = 2 Then 'Autre
    txt(1) = "Tableau:"
    txt(2) = Chr(32) & "Dimitri Ivanovitch"
    txt(3) = Chr(32) & "Mandeleïev"
    txt(4) = Chr(32) & "1869"
    txt(5) = Chr(32) & "né: 1834"
    txt(6) = Chr(32) & "décès: 1907"
    txt(7) = Chr(32) & ""
End If
'--- Texte final à traiter ---
    For i = 1 To 7
        txt8 = txt8 & txt(i)
    Next i
'--- Calcul de F (longueur fin de texte) ---
    For i = 1 To 7
        F(i) = Len(txt(i))
    Next i
'--- Calcul de D (début du texte) ---
    D(1) = 1
    For i = 2 To 7
        If i = 2 Then
            D(i) = D(i - 1) + Len(txt(i - 1)) + 1
        Else
            D(i) = D(i - 1) + Len(txt(i - 1))
        End If
    Next i
'----- Contrôle présence Commentaire -----
    With Range(Adr)
        If Not .Comment Is Nothing Then .Comment.Delete
        .AddComment txt8
        Set cmt = .Comment
        cmt.Visible = False
    End With
'------------ Couleurs + gras ------------
With cmt.Shape.TextFrame
    .Characters(D(1), F(1)).Font.ColorIndex = Range("Color1").Value  'txt1
    .Characters(D(1), F(1)).Font.Bold = True
    .Characters(D(2), F(2)).Font.ColorIndex = Range("Color2").Value  'txt2
    .Characters(D(2), F(2)).Font.Bold = True
    .Characters(D(3), F(3)).Font.ColorIndex = Range("Color3").Value  'txt3
    .Characters(D(3), F(3)).Font.Bold = True
    .Characters(D(4), F(4)).Font.ColorIndex = Range("Color4").Value  'txt4
    .Characters(D(4), F(4)).Font.Bold = True
    .Characters(D(5), F(5)).Font.ColorIndex = Range("Color5").Value  'txt5
    .Characters(D(5), F(5)).Font.Bold = True
    .Characters(D(6), F(6)).Font.ColorIndex = Range("Color6").Value  'txt6
    .Characters(D(6), F(6)).Font.Bold = True
    .Characters(D(7), F(7)).Font.ColorIndex = Range("Color7").Value  'txt7
    .Characters(D(7), F(7)).Font.Bold = True
End With
'---------- Police ----------
    cmt.Shape.TextFrame.Characters.Font.Italic = True
    cmt.Shape.TextFrame.Characters.Font.Size = 20
'---------- épaisseur bordure ----------
    cmt.Shape.Line.Weight = 1.5
'---------- Couleur Bordure ----------
    cmt.Shape.Line.ForeColor.RGB = RGB(255, 0, 0)
'---------- Type ----------
    cmt.Shape.AutoShapeType = msoShapeHorizontalScroll 'msoShapeVerticalScroll 'msoShapeHorizontalScroll 'msoShapeRoundedRectangle
'---------- Fond du commentaire ----------
With Sheets("Feuil1")
    R = .Range("C2").Value
    G = .Range("C3").Value
    B = .Range("C4").Value
End With
With cmt.Shape.Fill
    .ForeColor.RGB = RGB(R, G, B)
    .Solid
End With
'---------- Ajustement automatique ----------
    cmt.Shape.TextFrame.AutoSize = True
ActiveCell.Comment.Visible=True
End Sub
'=================================

Salutation
Jean-Paul