Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2021 Comment lister mardi et mercredi d'une année VBA

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Désolé c'est pas très clair, voici le rendu image qui irai bien.
Faudrait que les dates démarra en A3, et que les lignes total et total heure soit automatique vba
entre chaque mois comme la photo.
Jusque en bas.
En espérant que se soit plus compréhensif en visu
Merci beaucoup

Le plus compliqué c'est de définir chaque plages de cellules et de les additionner entre 2 mois, et en le faisant proprement
 

Pièces jointes

  • mon idée.jpg
    136.2 KB · Affichages: 15
Dernière édition:

job75

XLDnaute Barbatruc
Je comprends que les heurs travaillées sont entrées manueellement.

La nouvelle macro qui crée 2 MFC :
VB:
Private Sub Worksheet_Calculate()
Dim efface As Boolean, dat&, i&, a(1 To 118, 1 To 2) '118 = 2 x 53 semaines + 12
efface = Year(Date) <> Year(CStr([Jour])) 'test pour le début de l'année
Application.ScreenUpdating = False
[A3].Resize(UBound(a), 2).NumberFormat = "General" 'RAZ
For dat = DateSerial([A1], 1, 1) To DateSerial([A1], 12, 31)
    If Weekday(dat) = 3 Then
        i = i + 1
        a(i, 1) = dat
        If efface Then a(i, 2) = Empty Else a(i, 2) = Cells(i + 2, 2)
        Cells(i + 2, 1).NumberFormat = """Mardi"" * dd/mm/yyyy" 'format Date personnalisé
    ElseIf Weekday(dat) = 4 Then
        i = i + 1
        a(i, 1) = dat
        If efface Then a(i, 2) = Empty Else a(i, 2) = Cells(i + 2, 2)
        Cells(i + 2, 1).NumberFormat = """Mercredi"" * dd/mm/yyyy" 'format Date personnalisé
    End If
    If Month(dat) < Month(dat + 1) Then
        i = i + 1 'saut de ligne
        a(i, 2) = "=SUBTOTAL(9,B$3:B" & i + 1 & ")"
        Cells(i + 2, 2).NumberFormat = """Total ""0"
    End If
Next dat
a(i + 1, 2) = "=SUBTOTAL(9,B$3:B" & i + 2 & ")" 'dernier Total
Cells(i + 3, 2).NumberFormat = """Total ""0"
Application.EnableEvents = False 'désactive les évènements
With [A3].Resize(UBound(a))
    .Resize(, 2).FormatConditions.Delete 'RAZ
    ThisWorkbook.Names.Add "Jour", Date 'nom défini
    ThisWorkbook.Names.Add "Mini", "=MIN(ABS(" & .Address & "-Jour))" 'formule matricielle nommée
    .FormatConditions.Add xlExpression, Formula1:="=ABS(A3-Jour)=Mini"
    .FormatConditions(1).Interior.Color = vbRed
    .FormatConditions(1).Font.Color = vbWhite
    .FormatConditions(1).Font.Bold = True 'gras
    With .Offset(, 1).SpecialCells(xlCellTypeFormulas)
        .FormatConditions.Add xlExpression, Formula1:=1
        .FormatConditions(1).Interior.Color = vbCyan
    End With
    .Resize(, 2) = a 'restitution
End With
Columns("A:B").AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

  • Mardi et Mercredi.xlsm
    24 KB · Affichages: 2

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Re,
Désolé d'abusé de votre temps, comme sur l'image jointe, c'est peut-être pas assez compréhensif, J'aimerai si possible "total" en colonne "A" entre 2 mois Et comme votre exemple, le total des heures en "B13" pour la plage d'heure du mois de janvier. ( 1 Total pour chaque mois prenant les 0.5 heure )
Et avec votre exemple, si je rajoute à la 1/2 heure, ça ne prend en compte cas l'arrondi supérieur (0.50).
Je pensais que l'image était compréhensive, désolé.
Merci.


Comme je disais précedement: Le plus compliqué c'est de définir chaque plages de cellules et de les additionner entre 2 mois, et en le faisant proprement.
Malgré mon bricolage c'est un peu près le résultat que j'avais.
 

Pièces jointes

  • mon idée.jpg
    136.2 KB · Affichages: 12
Dernière édition:

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Je me reprends escusez-moi, en gros entre 2 mois, soit en colonne"A", juste le texte "Total" du mois concerné, et juste à coté, total des "Heures" en prenant en compte les 0.5 hrs.
Je sais pas comment expliquer mieux.
merci
 
Dernière édition:

job75

XLDnaute Barbatruc
J'espère que cette fois-ci c'est bien ce que vous voulez :
VB:
Private Sub Worksheet_Calculate()
Dim efface As Boolean, deb&, dat&, i&, a(1 To 118, 1 To 2) '118 = 2 x 53 semaines + 12
efface = Year(Date) <> Year(Val(CStr([Jour]))) 'test pour le début de l'année
Application.ScreenUpdating = False
[A3].Resize(UBound(a), 2).NumberFormat = "General" 'RAZ
deb = 3
For dat = DateSerial([A1], 1, 1) To DateSerial([A1], 12, 31)
    If Weekday(dat) = 3 Then
        i = i + 1
        a(i, 1) = dat
        If efface Then a(i, 2) = Empty Else a(i, 2) = Cells(i + 2, 2)
        Cells(i + 2, 1).NumberFormat = """Mardi"" * dd/mm/yyyy" 'format Date personnalisé
    ElseIf Weekday(dat) = 4 Then
        i = i + 1
        a(i, 1) = dat
        If efface Then a(i, 2) = Empty Else a(i, 2) = Cells(i + 2, 2)
        Cells(i + 2, 1).NumberFormat = """Mercredi"" * dd/mm/yyyy" 'format Date personnalisé
    End If
    If Month(dat) < Month(dat + 1) Then
        i = i + 1 'saut de ligne
        a(i, 1) = 0
        a(i, 2) = "=SUM(B" & deb & ":B" & i + 1 & ")"
        Cells(i + 2, 1).NumberFormat = """Total"""
        deb = i + 3
    End If
Next dat
'---dernier Total---
a(i + 1, 1) = 0
a(i + 1, 2) = "=SUM(B" & deb & ":B" & i + 2 & ")"
Cells(i + 3, 1).NumberFormat = """Total"""
'---restitution et MFC---
Application.EnableEvents = False 'désactive les évènements
With [A3].Resize(UBound(a))
    .Resize(, 2) = a 'restitution
    .Resize(, 2).FormatConditions.Delete 'RAZ
    ThisWorkbook.Names.Add "Jour", Date 'nom défini
    ThisWorkbook.Names.Add "Mini", "=MIN(ABS(" & .Address & "-Jour))" 'formule matricielle nommée
    .FormatConditions.Add xlExpression, Formula1:="=ABS(A3-Jour)=Mini"
    .FormatConditions(1).Interior.Color = vbRed
    .FormatConditions(1).Font.Color = vbWhite
    .FormatConditions(1).Font.Bold = True 'gras
    .Resize(, 2).FormatConditions.Add xlExpression, Formula1:="=""""&$A3=""0"""
    .Resize(, 2).FormatConditions(2).Interior.Color = vbCyan
    .Resize(, 2).FormatConditions(2).Font.Bold = True 'gras
End With
Columns("A:B").AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

  • Mardi et Mercredi.xlsm
    24.9 KB · Affichages: 3
Dernière édition:

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Euh si je peux me permettre, c'est parfait.
Merci vraiment beaucoup, je vais l'étudier pour comprendre mais le résultat est ce que je voulais,mais c'est pas évident de se faire comprendre par message, comme les sms, je déteste. merci beaucoup, vraiment.
 

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
C'est vrai que c'est compliqué : je viens d'ajouter Val sur la 3ème ligne de la macro...

Pourquoi commencez-vous les dates en A3 et pas en A2 ?
C'est pas pour vous embêter promis, c'est juste si je veux ajouter des annotations au cas ou et je vais figer dans le haut, pour avoir de la place et pas vous embêter à nouveau.
et le Val j'ai pas compris ou et pour quoi ?
Merci encore
Nicolas
 

job75

XLDnaute Barbatruc
Je parlais du Val mis sur la ligne qui calcule la variable efface (3ème ligne).

Voici une nouvelle macro, il suffit de modifier sa 8ème ligne pour changer la ligne de début :
VB:
Private Sub Worksheet_Calculate()
Dim efface As Boolean, deb&, dat&, i&, a(1 To 118, 1 To 2) '118 = 2 x 53 semaines + 12
efface = Val(CStr([A1])) <> Val(CStr([Annee])) 'test pour le début de l'année
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
ThisWorkbook.Names.Add "Annee", Val([A1])
deb = 1
With [A3].Resize(UBound(a)) '1ère ligne à adapter au besoin
    .Resize(, 1 - efface).ClearContents 'RAZ
    For dat = DateSerial([Annee], 1, 1) To DateSerial([Annee], 12, 31)
        If Weekday(dat) = 3 Then
            i = i + 1
            a(i, 1) = dat
            If Not efface Then a(i, 2) = .Cells(i, 2)
            .Cells(i).NumberFormat = """Mardi"" * dd/mm/yyyy" 'format Date personnalisé
        ElseIf Weekday(dat) = 4 Then
            i = i + 1
            a(i, 1) = dat
            If Not efface Then a(i, 2) = .Cells(i, 2)
            .Cells(i).NumberFormat = """Mercredi"" * dd/mm/yyyy" 'format Date personnalisé
        End If
        If Month(dat) < Month(dat + 1) Then
            i = i + 1 'saut de ligne
            a(i, 1) = 0
            a(i, 2) = "=SUM(" & .Cells(deb, 2).Resize(i - deb).Address(0, 0) & ")"
            .Cells(i).NumberFormat = """Total"""
            deb = i + 1
        End If
    Next dat
    '---dernier Total---
    a(i + 1, 1) = 0
    a(i + 1, 2) = "=SUM(" & .Cells(deb, 2).Resize(i + 1 - deb).Address(0, 0) & ")"
    .Cells(i + 1, 1).NumberFormat = """Total"""
    '---restitution et MFC---
    .Resize(, 2) = a 'restitution
    .Resize(, 2).FormatConditions.Delete 'RAZ
    ThisWorkbook.Names.Add "Jour", Date 'nom défini
    ThisWorkbook.Names.Add "Mini", "=MIN(ABS(" & .Address & "-Jour))" 'formule matricielle nommée
    .FormatConditions.Add xlExpression, Formula1:="=ABS(A3-Jour)=Mini"
    .FormatConditions(1).Interior.Color = vbRed
    .FormatConditions(1).Font.Color = vbWhite
    .FormatConditions(1).Font.Bold = True 'gras
    .Resize(, 2).FormatConditions.Add xlExpression, Formula1:="=""""&$A3=""0"""
    .Resize(, 2).FormatConditions(2).Interior.Color = vbCyan
    .Resize(, 2).FormatConditions(2).Font.Bold = True 'gras
End With
Columns("A:B").AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

  • Mardi et Mercredi.xlsm
    21.6 KB · Affichages: 5

Discussions similaires

Réponses
4
Affichages
265
Réponses
5
Affichages
530
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…