[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

U
  • Question Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
345
Phil69970
Phil69970
U
  • Résolu(e)
Autres Centrer ou Annuler Centrer
Réponses
12
Affichages
510
un internaute
U
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
192
patricktoulon
patricktoulon
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 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
360
fanch55
fanch55
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
110
crocrocro
C
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
715
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
648
un internaute
U
B
  • Résolu(e)
XL 2019 Rw.RowHeight = 24
Réponses
7
Affichages
560
bauerjackob
B
U
  • Question Question
Autres [RÉSOLU] Problème macro mais lequel?
Réponses
4
Affichages
574
un internaute
U
U
  • Question Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
511
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
485
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
679
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
508
berru76
B
patricktoulon
  • Résolu(e)
XL 2013 le 12 doit commencer en haut
Réponses
7
Affichages
585
dysorthographie
dysorthographie
U
  • Résolu(e)
Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)
2
Réponses
15
Affichages
2 K
un internaute
U
T
  • Résolu(e)
XL 2019 Copier une zone de texte à intervalle régulier
Réponses
11
Affichages
921
thespeedy20
T
PHV.FSM
  • Question Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicolas JACQUIN
Nicolas JACQUIN
patricktoulon
  • Question Question
XL 2013 ajouter les shapes de connection pseudo organigramme style tree view
2
Réponses
21
Affichages
2 K
patricktoulon
patricktoulon
Retour