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

Trier par date Trier par votes
Nicolas JACQUIN

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
    mon idée.jpg
    136.2 KB · Affichages: 15
Dernière édition:
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
job75 à dit:
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
Cliquez pour agrandir...
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
    mon idée.jpg
    136.2 KB · Affichages: 12
Dernière édition:
Vote positif 0 Vote négatif
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Nico_J à dit:
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. ;) ;)
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
job75

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: 2
Dernière édition:
Vote positif 0 Vote négatif
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
job75 à dit:
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(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
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
job75 à dit:
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 ?
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif

Discussions similaires

libellule85
  • Question
Microsoft 365 Connaitre le nombre de mardi, mercredi etc.. dans une colonne dynamique
Réponses
7
Affichages
187
Gégé-45550
Gégé-45550
C
  • Question
XL pour MAC Répartir des personnes dans des équipes par roulement sur 5 jours
Réponses
6
Affichages
665
job75
job75
Electron24
  • Question
Microsoft 365 Graphique par date
Réponses
4
Affichages
166
Electron24
Electron24
LB04
  • Question
XL 2019 compter les vendredi entre deux dates
Réponses
11
Affichages
573
LB04
LB04
D
  • Résolu(e)
Microsoft 365 planning repos tournant
Réponses
5
Affichages
490
piga25
piga25
C
Bonjour je m'appelle christelle. Je vis en ecovillage dans le sud en Ariege
Réponses
1
Affichages
297
Aya_flo
A
J
  • Question
XL 2013 Problème planning : mise en forme conditionnelle report période sur tableau
Réponses
5
Affichages
144
JHA
J
eddy1975
  • Résolu(e)
XL 2019 Heures réelles du mois
Réponses
3
Affichages
412
eddy1975
eddy1975
B
  • Résolu(e)
Microsoft 365 Recherche formule
Réponses
7
Affichages
614
TooFatBoy
TooFatBoy
T
  • Résolu(e)
XL 2010 VAB - Lister et renommer fichiers en bloc
Réponses
6
Affichages
335
tchi456
T

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 56 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 628
Messages
2 111 337
Membres
111 104
dernier inscrit
JEMADA