[RÉSOLU) Ecrire 2019 en couleur par macro

[un internaute]

Bonjour le forum
Dans la macro ci-dessous j'ai ajouté les lignes en rouge pour pouvoir faire passer 2019
Ça fonctionne bien sauf que je n'ai pas 2019 en rouge (Montant Eau chaude année 2019)
Quelqu'un a t-il une idée où ça bloque?
Merci pour vos retours.
Cordialement

Sub NouvelleAnnee()
Dim NomFeuille As String
Dim An As Integer
Dim Couleur
Dim Sh As Shape

  Couleur = Array(3, 4, 5, 6, 7, 8, 9, 10, 17, 40, 49, 42)
  With ActiveSheet
    An = Val(Split(.Name, " ")(1))
    If An = 0 Then
      MsgBox "Nom de la feuille non conforme"
      Exit Sub
    End If
    .Unprotect
    NomFeuille = "Charges " & An + 1

    .Copy after:=Sheets(Sheets.Count)
    '.Shapes("AnneePlus").Delete     'Mettre en commentaires pour ne pas effacer le bouton (nouvelle année)de la Feuille Précédente
    .Protect
  End With
  With ActiveSheet
    .Name = NomFeuille
    .Tab.ColorIndex = Couleur((An - 2000) Mod 12)
    .Range("E5:E6,A10:C14,E10:E14,A16:C27,E16:E27,A38:C42,E38:E42,A44:C55,E44:E55,A66:C70,E66:E70,A72:C83,E72:E83,A94:C98,E94:E98,A100:C111,E100:E111,F7,F35,F63,F91,G7:I7,G17:I21,I27,G23:I27,G46:I49,G51:I55,G73:I77,G79:I83,G101:I105,G107:I111,G117:I117,G119:I119").ClearContents
    .Cells.Replace What:=An, Replacement:=An + 1
     For Each Sh In .Shapes
       If Sh.TopLeftCell.Column = 2 Then     '2 = Colonne B
        With Sh.TextFrame.Characters(Start:=127, Length:=4)
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        Exit For
      End If
    Next Sh
         For Each Sh In .Shapes
       If Sh.TopLeftCell.Column = 7 Then     '7 = Colonne G
        With Sh.TextFrame.Characters(Start:=18, Length:=4)
        With Sh.TextFrame.Characters(Start:=26, Length:=4)
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        End With
        Exit For
      End If
    Next Sh
        
  .Range("A1").Select
  End With
End Sub

 

[Lone-wolf]

Bonjour un internaute,

si c'est With Sh.TextFrame.Characters(Start:=127, Length:=4) pour Montant Eau chaude année 2019, compte bien les craractères + les espaces.

 

[un internaute]

Bonjour Lone-Wolf,
Oups effectivement ce n'est pas With Sh.TextFrame.Characters

C'est => With ActiveCell.Characters(Start:=26, Length:=4).Font
La macro accroche.
Merci à toi
A voir
A+

 

[un internaute]

Re-bonjour le forum
Ajout de la ligne en rouge
Merci
Bonne fin de journée
Cordialement

Option Explicit

Sub NouvelleAnnee()
Dim NomFeuille As String
Dim An As Integer
Dim Couleur
Dim Sh As Shape

  Couleur = Array(3, 4, 5, 6, 7, 8, 9, 10, 17, 40, 49, 42)
  With ActiveSheet
    An = Val(Split(.Name, " ")(1))
    If An = 0 Then
      MsgBox "Nom de la feuille non conforme"
      Exit Sub
    End If
    .Unprotect
    NomFeuille = "Charges " & An + 1

    .Copy after:=Sheets(Sheets.Count)
    '.Shapes("AnneePlus").Delete
    .Protect
  End With
  With ActiveSheet
    .Name = NomFeuille
    .Tab.ColorIndex = Couleur((An - 2000) Mod 12)
    .Range("E5:E6,A10:C14,E10:E14,A16:C27,E16:E27,A38:C42,E38:E42,A44:C55,E44:E55,A66:C70,E66:E70,A72:C83,E72:E83,A94:C98,E94:E98,A100:C111,E100:E111,F7,F35,F63,F91,G7:I7,G17:I21,I27,G23:I27,G46:I49,G51:I55,G73:I77,G79:I83,G101:I105,G107:I111,G117:I117,G119:I119").ClearContents
    '.Range("E5:E6,A10:C14,E10:E14,A16:C27,E16:E27,A38:C42,E38:E42,A44:C55,E44:E55,A66:C70,E66:E70,A72:C83,E72:E83,A94:C98,E94:E98,A100:C111,E100:E111,F7,F35,F63,F91,G7:I7,G17:I21,I27,G23:I27,G45:I49,G51:I55,G73:I77,G79:I83,G101:I105,G107:I111,G117:I117,G119:I119").Interior.ColorIndex = 8
    'La ligne ci-dessous permer d'ajouter 1 année de plus dans la feuille excel.Cellules A1, A2,A22, A40, A58
    .Cells.Replace What:=An, Replacement:=An + 1
   
    .Range("G45").Characters(Start:=26, Length:=4).Font.ColorIndex = 3
   
      For Each Sh In .Shapes                  '
  
       If Sh.TopLeftCell.Column = 2 Then     '2 = Colonne B
        With Sh.TextFrame.Characters(Start:=127, Length:=4)
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        Exit For
      End If
    Next Sh
         For Each Sh In .Shapes
       If Sh.TopLeftCell.Column = 7 Then     '7 = Colonne G
        With Sh.TextFrame.Characters(Start:=18, Length:=4)
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        Exit For
      End If
    Next Sh
      
  .Range("A1").Select
  End With
End Sub

Sub NouvelleAnneeOLd()        'OLd pour différencier cette Macro avec la précédente
Dim NomFeuille As String
Dim An As Integer
Dim Couleur
Dim Sh As Shape

  Couleur = Array(3, 4, 5, 6, 7, 8, 9, 10, 17, 40, 49, 42)
  With ActiveSheet
    An = Val(Split(.Name, " ")(1))
    If An = 0 Then
      MsgBox "Nom de la feuille non conforme"
      Exit Sub
    End If
    .Unprotect
    NomFeuille = "Charges " & An + 1 'Espace après Charges affiche Charges 2014.Supprimer Espace affiche par exemple Charges2014

    .Copy after:=Sheets(Sheets.Count)
    '.Shapes("AnneePlus").Delete     'Mettre en commentaires pour ne pas effacer le bouton (nouvelle année)de la Feuille Précédente
    .Protect
  End With
  With ActiveSheet
    .Name = NomFeuille
    .Tab.ColorIndex = Couleur((An - 2000) Mod 12)
    .Range("E5:E6,A10:C14,E10:E14,A16:C27,E16:E27,A38:C42,E38:E42,A44:C55,E44:E55,A66:C70,E66:E70,A72:C83,E72:E83,A94:C98,E94:E98,A100:C111,E100:E111,F7,F35,F63,F91,G7:I7,G17:I21,I27,G23:I27,G46:I49,G51:I55,G73:I77,G79:I83,G101:I105,G107:I111,G117:I117,G119:I119").ClearContents
    '.Range("E5:E6,A10:C14,E10:E14,A16:C27,E16:E27,A38:C42,E38:E42,A44:C55,E44:E55,A66:C70,E66:E70,A72:C83,E72:E83,A94:C98,E94:E98,A100:C111,E100:E111,F7,F35,F63,F91,G7:I7,G17:I21,I27,G23:I27,G45:I49,G51:I55,G73:I77,G79:I83,G101:I105,G107:I111,G117:I117,G119:I119").Interior.ColorIndex = 8
    'La ligne ci-dessous permer d'ajouter 1 année de plus dans la feuille excel.Cellules A1, A2,A22, A40, A58
    .Cells.Replace What:=An, Replacement:=An + 1          'Cette ligne pour modifier l'Année dans TOUTES les CELLULES de la Feuille Excel.Exemple => 2015 par 2016
  
     .Range("G45").Characters(Start:=26, Length:=4).Font.ColorIndex = 3  'Pour afficher 2019 en rouge couleur
  
     For Each Sh In .Shapes                  'Ces 10 lignes pour ajouter une année soit par exemple 2017 à la place de 2016 dans Bouton macro Afficher / Masquer
       If Sh.TopLeftCell.Column = 2 Then     '2 = Colonne B
        With Sh.TextFrame.Characters(Start:=127, Length:=4)   'Pour obtenir les nombres 145 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=145, Length:=4).Font. Mettre Sh.TextFrame à la place de Selection
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        Exit For
      End If
    Next Sh
             For Each Sh In .Shapes                  'Ces 10 lignes pour ajouter une année soit par exemple 2017 à la place de 2016 dans Bouton macro Afficher / Masquer
       If Sh.TopLeftCell.Column = 7 Then     '7 = Colonne G
        With Sh.TextFrame.Characters(Start:=18, Length:=4)   'Pour obtenir les nombres 145 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=145, Length:=4).Font. Mettre Sh.TextFrame à la place de Selection
          .Insert An + 1         ' Incrémentation d'un an
          .Font.ColorIndex = 3   ' Couleur année
          .Font.Size = 20        ' Taille texte
        End With
        Exit For
      End If
    Next Sh

    .Range("A1").Select
  End With
End Sub