XL 2019 Convertir date en mois et année par macro

Rabeto · 23 Janvier 2024

Bonjour,

Y a t-il y moyen de convertir une liste de date en Mois et année par Macro svp,

Par formule pas de soucis, mais j'ai tellement beaucoup de ligne à convertir et ça ralenti mon fichier,
Donc je penses que par VBA serai mieux

PS : Résultats à mettre dans la colonne des dates si possible, et dans une colonne à côté l'année

Merci

mapomme · 23 Janvier 2024

Bonsoir @Rabeto ,

Placer le code qui suit dans un module. Ce code agit sur la feuille active.
Suivant le format du mois désiré, modifier "mmmm" dans pour :

"mmmm" pour un mois en lettre : nom complet du mois
"mmm" pour un mois en lettre : nom abrégé du mois
"mm" pour un mois en chiffre : toujours sur deux chiffres
"m" pour un mois en chiffre : sur un ou deux chiffres

VB:

Sub dateMoisAnnee()
Const Mois = "ja,f,mar,av,mai,juin,juil,ao,se,oc,no,d"
Dim deb!, der&, tmois, t, i&, k&, x, s
   deb = Timer
   Application.ScreenUpdating = False
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      t = Range("a2:a" & der).Value
      tmois =...

mapomme · 23 Janvier 2024

Bonsoir @Rabeto ,

Placer le code qui suit dans un module. Ce code agit sur la feuille active.
Suivant le format du mois désiré, modifier "mmmm" dans pour :

"mmmm" pour un mois en lettre : nom complet du mois
"mmm" pour un mois en lettre : nom abrégé du mois
"mm" pour un mois en chiffre : toujours sur deux chiffres
"m" pour un mois en chiffre : sur un ou deux chiffres

VB:

Sub dateMoisAnnee()
Const Mois = "ja,f,mar,av,mai,juin,juil,ao,se,oc,no,d"
Dim deb!, der&, tmois, t, i&, k&, x, s
   deb = Timer
   Application.ScreenUpdating = False
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      t = Range("a2:a" & der).Value
      tmois = Split(Mois, ",")
      ReDim Preserve t(1 To UBound(t), 1 To 2)
      For i = 1 To UBound(t)
         x = Application.Trim(Replace(Replace(t(i, 1), """", ""), ".", ""))
         t(i, 1) = Empty
         s = Split(LCase(x))
         For k = LBound(tmois) To UBound(tmois)
            If s(1) Like tmois(k) & "*" Then Exit For
         Next k
         If k <= UBound(tmois) Then
            t(i, 1) = Format(DateSerial(s(2), k + 1, 1), "mmmm")
            t(i, 2) = Format(DateSerial(s(2), k + 1, 1), "yyyy")
         End If
      Next i
      .Range("b2:c" & Rows.Count).Clear
      .Range("b2:c2").Resize(UBound(t)) = t
   End With
   MsgBox Format((Timer - deb) * 1000, "#,##0\ millisec. pour ") & Format(UBound(t), "#,##0 lignes traitées")
End Sub

Rabeto · 24 Janvier 2024

Bonjour mapomme,

Merci beaucoup, c'est exactement comme ça, en plus vous avez rajouté quelques choses que j'ai toujours cherché (le timing MsgBox) c'est super

Merci infiniment

job75 · 24 Janvier 2024

Bonjour Rabeto, mapomme, le forum,

A priori il s'agit d'une simple conversion, c'est très simple :

VB:

Sub Convertir()
Dim tablo, i&, dat
With [A1].CurrentRegion.Resize(, 2)
    tablo = .Value
    For i = 2 To UBound(tablo)
        dat = Mid(tablo(i, 1), 2)
        If IsDate(dat) Then tablo(i, 2) = CDate(dat) Else tablo(i, 2) = ""
    Next
    .Value = tablo
    .Columns(3).Offset(1) = .Columns(2).Offset(1).Value 'copie les valeurs
    .Columns(2).NumberFormat = "mmmm"
    .Columns(3).NumberFormat = "yyyy"
End With
End Sub

A+

job75 · 24 Janvier 2024

Au post #1 vous parlez de formules alors voyez cette macro :

VB:

Sub Convertir2()
With [A1].CurrentRegion
    If .Rows.Count = 1 Then Exit Sub
    With .Rows(2).Resize(.Rows.Count - 1)
        .Columns(2) = "=TEXT(MID(A2,2,LEN(A2)-7),""mmmm"")"
        .Columns(3) = "=--RIGHT(A2,4)"
    End With
End With
End Sub

Sur 100 000 lignes elle s'exécute en 0,27 seconde contre 0,92 seconde pour celle du post #4.

Rabeto · 24 Janvier 2024

Bonjour job75;

J'ai été toujours impressionné par vos réponses et l'efficacité de vos macros,

merci infiniment,

XL 2019 Convertir date en mois et année par macro

Rabeto

XLDnaute Occasionnel

Pièces jointes

mapomme

mapomme

XLDnaute Barbatruc

Pièces jointes

Rabeto

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Rabeto

XLDnaute Occasionnel

Discussions similaires