Peut-on réunir les 3 en un?

Le 31/01/2020 à 12:57

Bonjour le forum

Dans le code général ci-dessous j'ai 3 fois ce code

    .[A14].Characters(Start:=17, Length:=4).Font.ColorIndex = 3

     .[A14].Characters(Start:=23, Length:=9).Font.ColorIndex = 3

     .[A14].Characters(Start:=39, Length:=4).Font.ColorIndex = 3

Peut-on réunir les 3 en 1?

Merci pour vos éventuels retours

 .[A1].Characters(Start:=38, Length:=5).Font.ColorIndex = 3

     .[A2].Characters(Start:=16, Length:=4).Font.ColorIndex = 3

     .[A7].Characters(Start:=1, Length:=4).Font.ColorIndex = 3

     .[A14].Characters(Start:=17, Length:=4).Font.ColorIndex = 3

     .[A14].Characters(Start:=23, Length:=9).Font.ColorIndex = 3

     .[A14].Characters(Start:=39, Length:=4).Font.ColorIndex = 3

     .[A8].Characters(Start:=20, Length:=4).Font.ColorIndex = 3

     .[B3].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[B9].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[C3].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[C9].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[D3].Characters(Start:=38, Length:=4).Font.ColorIndex = 3

     .[D9].Characters(Start:=38, Length:=4).Font.ColorIndex = 3

     .[E3].Characters(Start:=21, Length:=4).Font.ColorIndex = 3

     .[E9].Characters(Start:=21, Length:=4).Font.ColorIndex = 3
Le 31/01/2020 à 13:20

Bonjour,

Call Joli(.[A14],17,4)
Call Joli(.[A14],24,9)

Sub Joli(A As Range, Start As Integer, Length As Integer)
  A.Characters(Start, Length).Font.ColorIndex = 3
End Sub

Ce serait plus joli.

Le 31/01/2020 à 13:50

Bonjour oxydum

Oh! là là un peu trop dur pour moi

je mets le code en entier ce sera mieux pour toi..et moi!!!

Cordialement

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

  Application.ScreenUpdating = False
  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 = "Retraites " & 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("B4:B6,B10:B12,C17,E4:E6,E10:E12").ClearContents
    '.Range("B4:B6,B10:B12,C17,F4:F6,F10:F12").Interior.ColorIndex = 8

     .Cells.Replace What:=An, Replacement:=An + 1
     .Cells.Replace What:=An - 1, Replacement:=An

    Call Joli(.[A14], 17, 4)
    Call Joli(.[A14], 24, 9)
     .[A1].Characters(Start:=38, Length:=5).Font.ColorIndex = 3

     .[A2].Characters(Start:=16, Length:=4).Font.ColorIndex = 3

     .[A7].Characters(Start:=1, Length:=4).Font.ColorIndex = 3

     .[A14].Characters(Start:=17, Length:=4).Font.ColorIndex = 3

     .[A14].Characters(Start:=23, Length:=9).Font.ColorIndex = 3

     .[A14].Characters(Start:=39, Length:=4).Font.ColorIndex = 3

     .[A8].Characters(Start:=20, Length:=4).Font.ColorIndex = 3

     .[B3].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[B9].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[C3].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[C9].Characters(Start:=51, Length:=4).Font.ColorIndex = 3

     .[D3].Characters(Start:=38, Length:=4).Font.ColorIndex = 3

     .[D9].Characters(Start:=38, Length:=4).Font.ColorIndex = 3

     .[E3].Characters(Start:=21, Length:=4).Font.ColorIndex = 3

     .[E9].Characters(Start:=21, Length:=4).Font.ColorIndex = 3

    With .Range("C4:C6")
      .Copy
      ActiveSheet.Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
      .ClearContents
    End With

    With .Range("C10:C12")
      .Copy
      ActiveSheet.Range("B10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
      .ClearContents
    End With
    .Range("A1").Select

  End With
End Sub
Le 31/01/2020 à 16:41

Avec ce classeur c'est encore plus simple

9retraite.xlsm (25.82 Ko)
Le 31/01/2020 à 17:50

Re oxydum

Nickel ça fonctionne super

Connaissais pas du tout

Merci à toi

Bonne fin de soirée

Le 01/02/2020 à 09:07

Bonjour oxydum et le forum

C'est super

Une question supplémentaire STP

Dans la macro ci-dessous j'ai une couleur supplémentaire.

Lignes de A4 à A6 = 3

Lignes de A7 à A8 = 5

Peut-on modifier aussi cette partie de la macro comme ce que tu as fait pour les autres?

With .[A1]
     .Characters(Start:=1, Length:=13).Font.ColorIndex = 5
     .Characters(Start:=14, Length:=1).Font.ColorIndex = 15    'Pour qu'entre Charges, Année et 2019 ne soit pas souligné mettre la mëme couleur que le fond soit 15
     .Characters(Start:=15, Length:=4).Font.ColorIndex = 3
     End With

Merci pour ton retour

Cordialement

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

  Application.ScreenUpdating = False
  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
    If FeuilleExiste(NomFeuille) = True Then
      MsgBox "L'Année " & NomFeuille & " existe déjà "
      Exit Sub
    End If
    .Unprotect

    .Copy after:=Sheets(Sheets.Count)
    '.Shapes("AnneePlus").Delete
    .Protect
  End With
  With ActiveSheet
    .Name = NomFeuille
    .Tab.ColorIndex = Couleur((An - 2000) Mod 12)
    On Error Resume Next
    .Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    On Error GoTo 0
    '.Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    '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

      With .[A1]
     .Characters(Start:=1, Length:=13).Font.ColorIndex = 5
     .Characters(Start:=14, Length:=1).Font.ColorIndex = 15    'Pour qu'entre Charges, Année et 2019 ne soit pas souligné mettre la mëme couleur que le fond soit 15
     .Characters(Start:=15, Length:=4).Font.ColorIndex = 3
     End With

     .Cells.Replace What:=An, Replacement:=An + 1
     .Cells.Replace What:=An - 1, Replacement:=An

     Call Joli(.[A4], 16, 9)        '.Characters(Start:=16, Length:=9).Font.ColorIndex = 3
     Call Joli(.[A4], 29, 16)       '.[A4].Characters(Start:=29, Length:=16).Font.ColorIndex = 3

     Call Joli(.[A5], 7, 7)          '.[A5].Characters(Start:=7, Length:=7).Font.ColorIndex = 3
     Call Joli(.[A5], 18, 17)        '.[A5].Characters(Start:=18, Length:=17).Font.ColorIndex = 3

     Call Joli(.[A6], 26, 4)          '.[A6].Characters(Start:=26, Length:=4).Font.ColorIndex = 3
     Call Joli(.[A6], 38, 1)          '.[A6].Characters(Start:=38, Length:=1).Font.ColorIndex = 3
     Call Joli(.[A6], 40, 3)         '.[A6].Characters(Start:=40, Length:=3).Font.ColorIndex = 3

     Call Joli(.[A7], 16, 10)         '.[A7].Characters(Start:=16, Length:=10).Font.ColorIndex = 5
     Call Joli(.[A7], 30, 16)         '.[A7].Characters(Start:=30, Length:=16).Font.ColorIndex = 5

     Call Joli(.[A8], 7, 7)           '.[A8].Characters(Start:=7, Length:=7).Font.ColorIndex = 5
     Call Joli(.[A8], 18, 16)         '.[A8].Characters(Start:=18, Length:=16).Font.ColorIndex = 5

     For Each sh In .Shapes
       If sh.TopLeftCell.Column = 2 Then     '2 = Colonne B
        With sh.TextFrame.Characters(Start:=66, 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

  .[A1].Select
  End With
Application.ScreenUpdating = True
End Sub

Sub Joli(A As Range, Start As Integer, Length As Integer)  'Mettre cette macro si on veut que Call Joli fonctionne
  A.Characters(Start, Length).Font.ColorIndex = 3
End Sub
Le 01/02/2020 à 15:14

Oui, tu peux écrire en "joli" :

Call Joli(.[A1], 1, 13,5)
Call Joli(.[A1], 14, 1,15)
Call Joli(.[A1], 15, 4,3)

Il faut juste remplacer la procédure Joli par celle-ci :

Sub Joli(A As Range, Start As Integer, Length As Integer, Optional Couleur As Integer = 3)
  A.Characters(Start, Length).Font.ColorIndex = Couleur
End Sub
Le 01/02/2020 à 15:38

Re oxydum

Si j'ai bien tout suivi et compris ça donne le code ci-dessous?

Mais ça bloque sur cette ligne

Call Joli(.[A1], 1, 13, 5)    '.Characters(Start:=1, Length:=13).Font.ColorIndex = 5
Sub NouvelleAnnee()
Dim NomFeuille As String
Dim An As Integer
Dim Couleur
Dim sh As Shape

  Application.ScreenUpdating = False
  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
    If FeuilleExiste(NomFeuille) = True Then
      MsgBox "L'Année " & NomFeuille & " existe déjà "
      Exit Sub
    End If
    .Unprotect

    .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)
    On Error Resume Next
    .Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    On Error GoTo 0
    '.Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    '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

      With .[A1]
        Call Joli(.[A1], 1, 13, 5)    '.Characters(Start:=1, Length:=13).Font.ColorIndex = 5
        Call Joli(.[A1], 14, 1, 15)    '.Characters(Start:=14, Length:=1).Font.ColorIndex = 15
        Call Joli(.[A1], 15, 4, 3)     '.Characters(Start:=15, Length:=4).Font.ColorIndex = 3

     End With

     .Cells.Replace What:=An, Replacement:=An + 1        '1ère phase on augmente de 1 l'année supérieure
     .Cells.Replace What:=An - 1, Replacement:=An        '2ème phase on augmente de 1 l'année inférieure

     Call Joli(.[A4], 16, 9)       '.Characters(Start:=16, Length:=9).Font.ColorIndex = 3
     Call Joli(.[A4], 29, 16)       '.[A4].Characters(Start:=29, Length:=16).Font.ColorIndex = 3

     Call Joli(.[A5], 7, 7)         '.[A5].Characters(Start:=7, Length:=7).Font.ColorIndex = 3
     Call Joli(.[A5], 18, 17)        '.[A5].Characters(Start:=18, Length:=17).Font.ColorIndex = 3

     Call Joli(.[A6], 26, 4)          '.[A6].Characters(Start:=26, Length:=4).Font.ColorIndex = 3
     Call Joli(.[A6], 38, 1)          '.[A6].Characters(Start:=38, Length:=1).Font.ColorIndex = 3
     Call Joli(.[A6], 40, 3)         '.[A6].Characters(Start:=40, Length:=3).Font.ColorIndex = 3

     Call Joli(.[A7], 16, 10)       '.[A7].Characters(Start:=16, Length:=10).Font.ColorIndex = 5
     Call Joli(.[A7], 30, 16)        '.[A7].Characters(Start:=30, Length:=16).Font.ColorIndex = 5

     Call Joli(.[A8], 7, 7)           '.[A8].Characters(Start:=7, Length:=7).Font.ColorIndex = 5
     Call Joli(.[A8], 18, 16)         '.[A8].Characters(Start:=18, Length:=16).Font.ColorIndex = 5

     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:=66, Length:=4)   'Pour obtenir les nombres 127 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=127, 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 18 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=18, 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

  .[A1].Select
  End With
Application.ScreenUpdating = True
End Sub

Sub Joli(A As Range, Start As Integer, Length As Integer, Optional Couleur As Integer)
  A.Characters(Start, Length).Font.ColorIndex = Couleur
End Sub

Merci à toi

Cordialement

Le 01/02/2020 à 15:53

Il faut supprimer le with

With .[A1]
        Call Joli(.[A1], 1, 13, 5)    '.Characters(Start:=1, Length:=13).Font.ColorIndex = 5
        Call Joli(.[A1], 14, 1, 15)    '.Characters(Start:=14, Length:=1).Font.ColorIndex = 15
        Call Joli(.[A1], 15, 4, 3)     '.Characters(Start:=15, Length:=4).Font.ColorIndex = 3
End With
Le 01/02/2020 à 16:11

Re

Comme ceci?

'      With .[A1]
     Call Joli(.[A1], 1, 13, 5)
     Call Joli(.[A1], 14, 1, 15)
     Call Joli(.[A1], 15, 4, 3)
'     End With
Le 01/02/2020 à 16:27

Parfait !

Le 01/02/2020 à 16:34

Mince les lignes 7 & 8 ne passent pas en 5 (bleu)

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

  Application.ScreenUpdating = False
  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
    If FeuilleExiste(NomFeuille) = True Then
      MsgBox "L'Année " & NomFeuille & " existe déjà "
      Exit Sub
    End If
    .Unprotect

    .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)
    On Error Resume Next
    .Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    On Error GoTo 0
    '.Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    '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

        Call Joli(.[A1], 1, 13, 5)    '.Characters(Start:=1, Length:=13).Font.ColorIndex = 5
        Call Joli(.[A1], 14, 1, 15)    '.Characters(Start:=14, Length:=1).Font.ColorIndex = 15
        Call Joli(.[A1], 15, 4, 3)     '.Characters(Start:=15, Length:=4).Font.ColorIndex = 3

     .Cells.Replace What:=An, Replacement:=An + 1
     .Cells.Replace What:=An - 1, Replacement:=An

     Call Joli(.[A4], 16, 9)       '.Characters(Start:=16, Length:=9).Font.ColorIndex = 3
     Call Joli(.[A4], 29, 16)       '.[A4].Characters(Start:=29, Length:=16).Font.ColorIndex = 3

     Call Joli(.[A5], 7, 7)         '.[A5].Characters(Start:=7, Length:=7).Font.ColorIndex = 3
     Call Joli(.[A5], 18, 17)        '.[A5].Characters(Start:=18, Length:=17).Font.ColorIndex = 3

     Call Joli(.[A6], 26, 4)          '.[A6].Characters(Start:=26, Length:=4).Font.ColorIndex = 3
     Call Joli(.[A6], 38, 1)          '.[A6].Characters(Start:=38, Length:=1).Font.ColorIndex = 3
     Call Joli(.[A6], 40, 3)         '.[A6].Characters(Start:=40, Length:=3).Font.ColorIndex = 3

     Call Joli(.[A7], 16, 10)       '.[A7].Characters(Start:=16, Length:=10).Font.ColorIndex = 5
     Call Joli(.[A7], 30, 16)        '.[A7].Characters(Start:=30, Length:=16).Font.ColorIndex = 5

     Call Joli(.[A8], 7, 7)           '.[A8].Characters(Start:=7, Length:=7).Font.ColorIndex = 5
     Call Joli(.[A8], 18, 16)         '.[A8].Characters(Start:=18, Length:=16).Font.ColorIndex = 5

     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:=66, Length:=4)   'Pour obtenir les nombres 127 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=127, 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 18 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=18, 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

  .[A1].Select
  End With
Application.ScreenUpdating = True
End Sub

Sub Joli(A As Range, Start As Integer, Length As Integer, Optional Couleur As Integer = 3)
  A.Characters(Start, Length).Font.ColorIndex = Couleur
End Sub
Le 01/02/2020 à 16:59
     Call Joli(.[A7], 16, 10, 5)       '.[A7].Characters(Start:=16, Length:=10).Font.ColorIndex = 5
     Call Joli(.[A7], 30, 16, 5)        '.[A7].Characters(Start:=30, Length:=16).Font.ColorIndex = 5

     Call Joli(.[A8], 7, 7, 5)           '.[A8].Characters(Start:=7, Length:=7).Font.ColorIndex = 5
     Call Joli(.[A8], 18, 16, 5)         '.[A8].Characters(Start:=18, Length:=16).Font.ColorIndex = 5
Le 01/02/2020 à 17:08

Re

Toujours pareil

Mince alors

Le 01/02/2020 à 17:24

Quel C$N!!!

Pas mis où il faut et le mauvais sub

UN GRAND MERCI A TOI

Bonne fin de soirée

Bien cordialement

Le 01/02/2020 à 17:42

Re oxydum

Je te remercie encore une fois tu as fait un heureux

Excellente soirée à toi...et à moi aussi!!!

Cordialement

Le 04/02/2020 à 06:57

Bonjour oxydum le forum

Voici la macro terminée

Encore un GRAND merci à toi oxydum

Cordialement

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

  Application.ScreenUpdating = False
  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
    If FeuilleExiste(NomFeuille) = True Then
      MsgBox "L'Année " & NomFeuille & " existe déjà "
      Exit Sub
    End If
    .Unprotect

    .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)
    On Error Resume Next
    .Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    On Error GoTo 0
    '.Range("E4:E8,A11:C15,E11:E15,A17:C30,E17:E30,A38:C42,E38:E42,A44:C57,E44:E57,A65:C69,E65:E69,A71:C84,E71:E84,A92:C96,E92:E96,A98:C111,E98:E111,F9,F36,F63,F90,G9:I9,G18:I23,G25:I30,G44:I50,G51:I57,G71:I77,G78:I84,G98:I104,G105:I111,G117:I117,G119:I119").SpecialCells(xlCellTypeConstants, 23).ClearContents
    'La ligne ci-dessous permer d'ajouter 1 année de plus dans la feuille excel et modifier l'Année dans TOUTES les CELLULES de la Feuille Excel.Exemple => 2019 par 2020
    .Cells.Replace What:=An, Replacement:=An + 1

       Call Joli(.[A1], 1, 13, 5)            'Ajouter 5 pour la couleur bleu (5) ligne 1
       Call Joli(.[A1], 14, 1, 15)           'Ajouter 15 pour qu'entre Charges et Année 2020 par exemple on ne voit pas le soulignement (mëme couleur que le fond soit 15)
       Call Joli(.[A1], 15, 4, 3)            'Ajouter 3 pour la couleur Rouge (3) ligne 1

     .Cells.Replace What:=An, Replacement:=An + 1        '1ère phase on augmente de 1 l'année supérieure
     .Cells.Replace What:=An - 1, Replacement:=An        '2ème phase on augmente de 1 l'année inférieure

        Call Joli(.[A4], 16, 9)
        Call Joli(.[A4], 29, 16)

        Call Joli(.[A5], 7, 7)
        Call Joli(.[A5], 18, 17)

        Call Joli(.[A6], 26, 4)
        Call Joli(.[A6], 38, 1)
        Call Joli(.[A6], 40, 3)

        Call Joli(.[A7], 16, 10, 5)          'Ajouter 5 pour la couleur bleu (5) ligne 7
        Call Joli(.[A7], 30, 16, 5)          'Ajouter 5 pour la couleur bleu (5) ligne 7
        Call Joli(.[A8], 7, 7, 5)            'Ajouter 5 pour la couleur bleu (5) ligne 8
        Call Joli(.[A8], 18, 16, 5)          'Ajouter 5 pour la couleur bleu (5) ligne 8

         For Each sh In .Shapes                  'Ces 10 lignes pour ajouter une année soit par exemple 2020 à la place de 2019 dans Simulation Année 2020
       If sh.TopLeftCell.Column = 7 Then         '7 = Colonne G
        With sh.TextFrame.Characters(Start:=18, Length:=4)   'Pour obtenir les nombres 18 & 4 faire: OUTILS => MACRO => NOUVELLE MACRO et les extraire de cette ligne dans la macro1:  With Selection.Characters(Start:=18, 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

  .[A1].Select
  End With
Application.ScreenUpdating = True
End Sub

Sub Joli(A As Range, Start As Integer, Length As Integer, Optional Couleur As Integer = 3)  'Ajouter la Macro "Joli" pour que le Programme fonctionne
  A.Characters(Start, Length).Font.ColorIndex = Couleur
End Sub
Rechercher des sujets similaires à "reunir"