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: 3
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
219
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
704
job75
job75
D
  • Résolu(e)
Microsoft 365 VBA - Lister les photos sélectées dans l'Explorateur Windows
2 3 4
Réponses
50
Affichages
1 K
danielco
D
R
  • Résolu(e)
Microsoft 365 Planning 5x8
Réponses
4
Affichages
265
fanfan38
fanfan38
Electron24
  • Question
Microsoft 365 Graphique par date
Réponses
4
Affichages
241
Electron24
Electron24
LB04
  • Question
XL 2019 compter les vendredi entre deux dates
Réponses
11
Affichages
631
LB04
LB04
D
  • Question
XL 2021 création de planning perpétuel annualisé
Réponses
1
Affichages
331
vgendron
vgendron
D
  • Résolu(e)
Microsoft 365 planning repos tournant
Réponses
5
Affichages
529
piga25
piga25
C
Bonjour je m'appelle christelle. Je vis en ecovillage dans le sud en Ariege
Réponses
1
Affichages
324
Aya_flo
A
J
  • Question
XL 2013 Problème planning : mise en forme conditionnelle report période sur tableau
Réponses
5
Affichages
179
JHA
J

Membres actuellement en ligne

16 membres et 121 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
315 093
Messages
2 116 130
Membres
112 667
dernier inscrit
foyoman