[RÉSOLU] Ajouter 1 an aux commentaires

un internaute

XLDnaute Impliqué
Bonjour le forum
Quelqu'un a fait ça l'autre jour
Peut-on l'adapter en lui faisant ajouter 1 an lorsque je passe en 2019?
Décembre 2017 deviendra donc Décembre 2018
Mes commentaires cellule A2 sont les suivants avec ces couleurs et sur 2 lignes:
Rappel consommation
Décembre 2017
Bien cordialement


VB:
Option Explicit
Sub CopieCommentaires()
Dim R As Worksheet 'déclare la variable R (onglet de Référence)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TC As String 'déclare la variable TC (Texte du Commentaire)

  Set R = Worksheets("Année 2018") 'définit l'onglet de référence R (celui où il y a le commentaire, à adapter)
  On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
  TC = R.Range("A2").Comment.Text 'définit le texte du commentaire TC (génère une erreur si A3 ne contient pas de commentaire)
  If Err <> 0 Then 'condition : si une erreur a été générée
     MsgBox "il n'y a pas de commentaire ! Action terminée." 'message
     Exit Sub 'sort de la procédure
  End If 'fin de la condition
  MsgBox "commentaire à copier :  " & TC
  Application.EnableEvents = False
  For Each O In Worksheets 'boucle sur tous les onglets O du classseur
     If O.Name <> R.Name Then 'condition : si le nom de l'onglet O est différent du nom de l'onget de référence R
       R.Range("A2").Copy O.Range("A2")
     End If 'fin de le condition
  Next O 'prochain onglet de la boucle
  Application.EnableEvents = True
End Sub
 
Dernière édition:

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour un internaute, bonjour le forum,

Pas sûr d'avoir bien compris mais remplace :

VB:
Set R = Worksheets("Année 2018") 'définit l'onglet de référence R (celui où il y a le commentaire, à adapter)
par :
VB:
Set R = Worksheets("Année " & Year(Date))
Ha, je crois connaître ce "quelqu'un"...
 

un internaute

XLDnaute Impliqué
Bonsoir Robert
Pour que tu n'es plus les boules!!!
Me voilà avec des modifs pour faire passer les commentaires à une année de plus
Mais pas comme je veux.
Commentaires cellule A2 et F2
Si on fait Nouvelle Année les commentaires passent bien en 2018 pour cellule A2 (actuellement 2017) et 2019 pour cellule F2 (actuellement 2018), mais je ne retrouve pas mes couleurs
La macro est AjoutAnnee
Est-ce possible?
Je suis en excel 2003
Bien cordialement
Fichier joint
 

Pièces jointes

  • TOTO.xls
    130.5 KB · Affichages: 23

un internaute

XLDnaute Impliqué
@Lone-wolf
Voilà et ce n'est pas de moi.
Merci à vous tous pour vos retours TOUJOURS instructifs pour moi.
Bonne soirée à tous
Cordialement

VB:
Option Explicit

Sub NouvelleAnnee()
  Dim Couleur, cel As Range, p As Byte, An0%, An1%, An2%
  If [A2].Comment Is Nothing Then
    MsgBox "il n'y a pas de commentaire ! Action terminée.": Exit Sub
  End If
  Couleur = Array(3, 5, 43, 6, 7, 33, 29, 27, 38, 46, 26, 6)
  Const plg1 As String * 27 = "A1, G1, B2, D2, H2, G16, J2"
  Const plg2 As String * 18 = "C2, D2, G2, J2, A3"
  Application.ScreenUpdating = False
  An1 = Val(Split(ActiveSheet.Name, " ")(1))
  If An1 = 0 Then MsgBox "Nom de la Feuille non Conforme": Exit Sub
  ActiveSheet.Copy , Sheets(Sheets.Count): An0 = An1 - 1: An2 = An1 + 1
  On Error GoTo ErrNomFeuille     'ça arrive si le nouveau nom existe déjà
  With ActiveSheet                'onglet de la NOUVELLE année
    .Unprotect: .Name = "Année " & An2
    .Tab.ColorIndex = Couleur((An2 - 2000) Mod 12)
  End With
  With [E3]
    .Formula = "='Année " & An1 & "'!E15": .Locked = -1: .FormulaHidden = -1
  End With
  For Each cel In Range(plg1)
    p = InStr(cel.Value, An1): cel.Characters(p, 4).Text = An2
  Next cel
  If Not [F2].Comment Is Nothing Then _
    [F2].Comment.Shape.TextFrame.Characters(35, 4).Text = An2
  For Each cel In Range(plg2)
    p = InStr(cel.Value, An0): cel.Characters(p, 4).Text = An1
  Next cel
  [A2].Comment.Shape.TextFrame.Characters(31, 4).Text = An1
  'attention : mettre en commentaire pour ne pas effacer
  'le bouton "nouvelle année" de la Feuille Précédente
  'ActiveSheet.Shapes("AnneePlus").Delete
  Range("E4:F15, H4:I15").ClearContents: [A1].Select
  ActiveSheet.Protect: Exit Sub
ErrNomFeuille:
  MsgBox "La feuille Année " & An2 & " existe déjà."
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
314 450
Messages
2 109 726
Membres
110 552
dernier inscrit
jasson