[RÉSOLU) Ecrire 2019 en couleur par macro

U

un internaute

XLDnaute Impliqué
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


Code: 
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
 
Trier par date Trier par votes
U

un internaute

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

Code: 
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
 
Vote positif 0 Vote négatif

Discussions similaires

U
  • Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
304
Phil69970
Phil69970
U
  • Résolu(e)
Autres Centrer ou Annuler Centrer
Réponses
12
Affichages
468
un internaute
U
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
936
Nicolas JACQUIN
Nicolas JACQUIN
D
  • Question
XL 2019 Message diffèrent en fonction état booléens
Réponses
3
Affichages
529
darkjedi
D
L
  • Question
Microsoft 365 Insérer une plage Excel en image sous VBA pour envoi mail auto
Réponses
1
Affichages
326
fanch55
fanch55
piga25
  • Résolu(e)
XL 2016 Mettre la même couleur de la dernière cellule colorée
Réponses
5
Affichages
299
TooFatBoy
TooFatBoy
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
513
laurent950
laurent950
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
326
souhaib ad
S
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
652
Messan
Messan
U
  • Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
628
un internaute
U

Membres actuellement en ligne

15 membres et 135 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 732
Messages
2 112 286
Membres
111 499
dernier inscrit
cg19