Macro + 6 mois

[karakoman1]

Bonjour à tous,
Je suis à la recherche d'une macro qui me permettrait d'extraire une date d'une chaine de caractères de la cellule dans laquelle je me trouve et la copier avec 6 mois supplémentaires, 6 cellules plus à droite. C'est probablement très simple pour beaucoup d'entre vous, mais moi, je sèche.
Merci d'avance

 

[pierrejean]

Re : Macro + 6 mois

Bonjour karakoman1

Vois si cela te convient

 

[karakoman1]

Re : Macro + 6 mois

Bonjour Pierrejean
C'est parfait!!!!
Je vais essayer de l'incorporer dans une autre macro qui faisait presque ça, c'est à dire qui changeait les différents formats de la cellule par rapport à sa recopie, mais sans pouvoir extraire ni changer la date.
Merci et à bientôt

 

[mapomme]

Re : Macro + 6 mois

Bonjour karakoman1, Pierrejean 🙂

Une autre manière avec une fonction personnalisée: extraire_date(X)

Cette fonction peut être mise où on le désire par rapport à la cellule X (voir fichier joint).

On a supposé, pour la validité des dates, que les dates sont au delà du 31/12/1999 (car la conversion par CDATE ou par Datevalue est assez permissive quant à la conversion - cdate(""45/10/11") et datevalue("45/10/11") retourne toutes les deux la date 11/10/1945 qui est une date somme toute valide - ).

Il faut bien sûr formater les cellules destination au format date.

Le code de la fonction extraire_date(X):

Function extraire_date(X)
Dim i As Long, D As Date

extraire_date = Null
For i = 1 To Len(X) - 7
  If Mid(X, i, 8) Like "##/##/##" Then
    On Error Resume Next
    D = CDate(Mid(X, i, 6) & "20" & Right(Mid(X, i, 8), 2))
    If Not IsError(D) And D > 0 Then
      D = DateSerial(Year(D), Month(D) + 6, Day(D))
      extraire_date = D
      Exit Function
    End If
  End If
Next i

End Function

 

[job75]

Re : Macro + 6 mois

Bonjour karakoman1, salut Pierre 🙂 et mapomme 🙂

Très en retard mais je dépose quand même mes 2 solutions :

1) par formule en G1 I2 K3 :

=SI(ESTNUM(date);DATE(ANNEE(date);MOIS(date)+6;JOUR(date));"")

2) par VBA :

Sub DatePlus()
Dim c As Range, t As String, i As Integer, dat As String
Application.ScreenUpdating = False
For Each c In ActiveSheet.UsedRange
  If Not IsDate(c) And c.Text Like "*##/##/##*" Then
    t = c.Text
    For i = 1 To Len(t) - 7
      dat = Mid(t, i, 8)
      If dat Like "##/##/##" And IsDate(dat) Then
        With c.Offset(, 6)
          .Value = DateSerial(Year(dat), Month(dat) + 6, Day(dat))
          .NumberFormat = "dd/mm/yy"
          .HorizontalAlignment = xlCenter
          .Interior.ColorIndex = 6 'coloration facultative
        End With
        Exit For
      End If
    Next
  End If
Next
End Sub

Les 2 fichiers joints.

A+

 

[karakoman1]

Re : Macro + 6 mois

Rebonjour à tous
Merci Mapomme, et Job75 de vous être penchés sur mon problème, mais Pierrejean était tombé presque "pile poil" sur le résultat attendu, à savoir, de la cellule sur laquelle je me trouve, me reporter 6 cases plus à droite en ayant extrait et modifié la date de 6 mois (1 colonne = 1 mois).
Je n'arrive cependant pas à intégrer à cette macro, dans un premier temps,de faire la mise en forme de ma cellule de départ (aucun remplissage et écriture bleu), de copier également la cellule précédent ma cellule contenant ma date à extraire (périodocité d'entretien qui ne sera pas toujours de 6 mois), deuxièmement de copier la date mise à jour dans la colonne B (pour mon exemple c'est la B, mais dans mon programme, c'est la R)et pour finir, de faire la mise en forme finale de la cellule contenant la date modifiée, qui serait un remplissage jaune avec écriture rouge et y rester.
Si il était possible que vous écriviez les explications à coté de chaque "fonction", ça me permettrais de rester moins... bête
Je remet le fichier un peu plus détaillé.
Merci d'avance pour votre patience

 

[pierrejean]

Re : Macro + 6 mois

Re

Salut Gerard
Salut mapomme

Vois si cela te convient

 

[job75]

Re : Macro + 6 mois

Bonjour karakoman1, salut mapomme, Pierre,

Ma macro adaptée pour le double-clic :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Target.Text Like "*##/##/##*" Then Exit Sub
Dim t$, i&, dat$
Cancel = True
t = Target.Text
For i = 1 To Len(t) - 7
  dat = Mid(t, i, 8)
  If dat Like "##/##/##" And IsDate(dat) Then
    Target.Interior.ColorIndex = xlNone
    Target.Font.Color = 11297280
    With Target(1, 7)
      .Offset(, -1) = Target(1, 0)
      .Value = DateSerial(Year(dat), Month(dat) + 6, Day(dat))
      Cells(Target.Row, "B") = .Value
      .NumberFormat = "dd/mm/yy"
      .HorizontalAlignment = xlCenter
      .Interior.Color = 65535
      .Font.Color = 255
    End With
    Exit For
  End If
Next
End Sub

On peut continuer à décaler les dates déjà décalées, si vous ne le voulez pas dites-le.

Fichier (2).

A+

 

[job75]

Re : Macro + 6 mois

Re,

(périodocité d'entretien qui ne sera pas toujours de 6 mois)

Si la périodicité indiquée n'est pas de 6 mois, il faut logiquement adapter le décalage :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Target.Text Like "*##/##/##*" Then Exit Sub
Dim t$, i&, dat$
Cancel = True
t = Target.Text
For i = 1 To Len(t) - 7
  dat = Mid(t, i, 8)
  If dat Like "##/##/##" And IsDate(dat) Then
    Target.Interior.ColorIndex = xlNone
    Target.Font.Color = 11297280
    With Target.Offset(, Val(Target(1, 0)))
      .Offset(, -1) = Target(1, 0)
      .Value = DateSerial(Year(dat), Month(dat) + Val(Target(1, 0)), Day(dat))
      Cells(Target.Row, "B") = .Value
      .NumberFormat = "dd/mm/yy"
      .HorizontalAlignment = xlCenter
      .Interior.Color = 65535
      .Font.Color = 255
    End With
    Exit For
  End If
Next
End Sub

Voir la périodicité de 3 mois dans ce fichier (3).

A+

 

[karakoman1]

Re : Macro + 6 mois

Bonjour Pierrejean, Job75 et le forum
Je viens de voir vos réponses.
Après test, le double-clic de Job75 ne convient pas, parceque je dois très souvent adatper le contenu de la cellule avant de faire fonctionner la macro. Sur ce point, il serait préférable la méthode à Pierrejean.
Par contre, Pierrejean, pourrais-tu faire inscrire également dans la colonne B la date extraite et faire que la cellule active soit la cellule jaune afin que je puisse également adatper son contenu.
La, ce serait parfait.
Merci à vous pour votre temps donné à aider les autres

 

[job75]

Re : Macro + 6 mois

Après test, le double-clic de Job75 ne convient pas, parceque je dois très souvent adatper le contenu de la cellule avant de faire fonctionner la macro.

Allons karakoman1, un peu d'imagination, il y a le clic droit :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Set Target = Target(1)
If Not Target.Text Like "*##/##/##*" Then Exit Sub
Dim t$, i&, dat$
Cancel = True
t = Target.Text
For i = 1 To Len(t) - 7
  dat = Mid(t, i, 8)
  If dat Like "##/##/##" And IsDate(dat) Then
    Target.Interior.ColorIndex = xlNone
    Target.Font.Color = 11297280
    With Target.Offset(, Val(Target(1, 0)))
      .Offset(, -1) = Target(1, 0)
      .Value = DateSerial(Year(dat), Month(dat) + Val(Target(1, 0)), Day(dat))
      Cells(Target.Row, "B") = .Value
      .NumberFormat = "dd/mm/yy"
      .HorizontalAlignment = xlCenter
      .Interior.Color = 65535
      .Font.Color = 255
    End With
    Exit For
  End If
Next
End Sub

Et si ça ne vous convient toujours pas affectez le code à un bouton en remplaçant Target par ActiveCell.

Fichier joint.

A+

 

[pierrejean]

Re : Macro + 6 mois

Re

Comme cela peut-être !!

 

[karakoman1]

Re : Macro + 6 mois

NICKEL!!!! Pierrejean
Un grand merci pour votre patience les amis
Job75, merci également, mais le double clic n'était pas ma solution.
Et merci aussi à Mapomme pour son essai.
A bientôt