[RÉSOLU) Ecrire 2019 en couleur par macro

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

VBA_dev_Anne_Marie
  • Question Question
Microsoft 365 VBA : copier les adresses
Réponses
7
Affichages
684
VBA_dev_Anne_Marie
VBA_dev_Anne_Marie
L
  • Question Question
Microsoft 365 Erreur automation 440 sur code VBA
Réponses
1
Affichages
301
job75
job75
patricktoulon
  • Question Question
Microsoft 365 datepicker dynamique intra userform ou dans feuille 2 versions(frame dynamique)(toute version d'excel )
6 7 8
Réponses
105
Affichages
3 K
Usine à gaz
Usine à gaz
U
  • Question Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
667
Phil69970
Phil69970
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
954
tnion
T
U
  • Résolu(e)
Autres Centrer ou Annuler Centrer
Réponses
12
Affichages
665
un internaute
U
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
586
patricktoulon
patricktoulon
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
Nicolas JACQUIN
L
  • Question Question
Microsoft 365 Insérer une plage Excel en image sous VBA pour envoi mail auto
Réponses
1
Affichages
457
fanch55
fanch55
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
655
crocrocro
C
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
1 K
Messan
Messan
U
  • Question Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
899
un internaute
U
B
  • Résolu(e)
XL 2019 Rw.RowHeight = 24
Réponses
7
Affichages
623
bauerjackob
B
U
  • Question Question
Autres [RÉSOLU] Problème macro mais lequel?
Réponses
4
Affichages
674
un internaute
U
U
  • Question Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
682
un internaute
U
U
  • Question Question
Autres [RÉSOLU] Pour faire afficher colonne F par double clic dans tout le classeur
Réponses
3
Affichages
561
vgendron
vgendron
M
  • Question Question
XL 2016 Erreur d'execution '52': Nom ou numéro de fichier incorrect
Réponses
4
Affichages
1 K
macseb
M
GADENSEB
  • Question Question
Microsoft 365 Macro .XLA découpage de fichiers à passer en X64
Réponses
8
Affichages
860
GADENSEB
GADENSEB
B
  • Résolu(e)
XL 2016 Modifier ou créer une macro de tri aléatoire par équipe de trois joueurs en lui ajoutant une colonne
Réponses
2
Affichages
555
berru76
B
patricktoulon
  • Résolu(e)
XL 2013 le 12 doit commencer en haut
Réponses
7
Affichages
631
dysorthographie
dysorthographie
Retour