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

[Nicolas JACQUIN]

Bonjour à tous,

Comment lister les mardi et les mercredi d'une année en VBA

Merci d'avance

 

[Gégé-45550]

Bonjour à tous,

Comment lister les mardi et les mercredi d'une année en VBA

Merci d'avance

Bonsoir,
Une possibilité en PJ.
Cordialement,

 

[Nicolas JACQUIN]

Bonjour, merci ça marche nickel
est ce que éventuellement on peut faire un écart entre chaque mois de 1 ou 2 lignes.
en vous remerciant

 

[sylvanu]

Bonjour Nico, Gégé,
Dans la macro de Gégé, il vous suffit de rajouter dans la boucle :

If Month(DayToTest) <> Mois Then Place = Place + 1: Mois = Mois + 1

 

[mapomme]

Bonjour à tous ,

Ma p'tite version... On peut paramétrer les jours de la semaine à lister et la cellule d'affichage à l'aide des deux constantes. On a pris en compte le saut d'une ligne à chaque changement de mois. Cliquez sur le bouton Hop!
Le code dans Module1 :

Sub JoursParticuliers()
Const Jours = "23"      ' lun->1; mar->2; mer->3; jeu->4; ven->5; sam->6; dim->7
Const Ici = "b4"        ' première cellule pour l'affichage du résultat
Dim Debut As Date, Fin As Date, i&, leMois&, n&

   With Sheets("Feuil1")
      Debut = Int(.[b1]): Fin = Int(.[b2]): leMois = Month(Debut)
      ReDim t(1 To (Fin - Debut + 1), 1 To 1)
      For i = Debut To Fin
         If InStr(Jours, Weekday(i, vbMonday)) > 0 Then
            If Month(i) <> leMois Then n = n + 1: leMois = Month(i)
            n = n + 1: t(n, 1) = i
         End If
      Next i
      .Range(.Range(Ici), .Cells(Rows.Count, "b")).Clear
      If n > 0 Then .Range(Ici).Resize(n) = t: .Range(Ici).Resize(n).NumberFormat = "ddd * dd mmm yyyy"
   End With
End Sub

nota : on n'est pas limité à deux jours. On peut prendre de 1 à 7 type de jour.

 

[Gégé-45550]

Bonjour, merci ça marche nickel
est ce que éventuellement on peut faire un écart entre chaque mois de 1 ou 2 lignes.
en vous remerciant

Bonjour,
Comme ça !
Cordialement,

 

[Nicolas JACQUIN]

Bonjour,
Merci à tous pour vos retours

 

[Nicolas JACQUIN]

Bonjour,
je suis pas ne flèche comme vous, mais merci je vais étudier ça, mais juste pourquoi

Const Jours = "23"

Ca veux dire quoi ?

Merci

 

[Gégé-45550]

Bonjour,
je suis pas ne flèche comme vous, mais merci je vais étudier ça, mais juste pourquoi

Ca veux dire quoi ?

Merci

Re
mapomme l'a expliqué dans le commentaire, c'est une constante qui agrège les chiffres 2 et 3 représentant respectivement le mardi (2) et le mercredi (3).
Si on voulait les samedis et dimanches, la constante contiendrait 67.
Cordialement,

 

[Nicolas JACQUIN]

Re
mapomme l'a expliqué dans le commentaire, c'est une constante qui agrège les chiffres 2 et 3 représentant respectivement le mardi (2) et le mercredi (3).
Si on voulait les samedis et dimanches, la constante contiendrait 67.
Cordialement,

oui ok, j'avais pas compris à la base, merci

 

[Nicolas JACQUIN]

J'ai encore une dernière requête et j'arrête promis ,
J'aimerai que la date la plus proche d'aujourd'hui sois coloré, est ce possible et comment.
Merci à tous.

 

[patricktoulon]

re
j'ai repris le fichier de @mapomme et j'ai fait un peu différemment

Option Explicit

Sub JoursParticuliers()
    Dim tbl(), J&, A&, D#, lig&
    Dim Debut As Date, Fin As Date, i&, leMois&, n&
    ' lun->1; mar->2; mer->3; jeu->4; ven->5; sam->6; dim->7' séparés par un espace
    Const Jours = " 2 3 "
    Const Ici = "b4"        ' première cellule pour l'affichage du résultat
    lig = 365
    With Sheets("Feuil1")
        Debut = Int(.[b1]): Fin = Int(.[b2])
        For J = 0 To 365
            D = CDate(Debut) + J
            If Jours Like "* " & Weekday(D, 2) & " *" Then
            A = A + 1: ReDim Preserve tbl(1 To A): tbl(A) = CLng(D)
            End If
            If D <= (Date - 7) Then lig = A
        Debug.Print lig
        Next
        With .Range(Ici).Resize(UBound(tbl))
            .ClearContents
            .Interior.Color = xlNone
            .Value = Application.Transpose(tbl)
            .NumberFormat = "dddd dd mmmm yyyy"
            .Cells(lig + 1).Interior.Color = vbRed
        End With
    End With
End Sub

 

[Nicolas JACQUIN]

Bonjour mon Patrick,
merci du retour, je pensais que le 10 avril aurait été coloré, mais non.
Moi franchement je sèche sur vos formules, je sais pas du tout.
Et l'espace entre chaques mois stp

et 1 ou 2 lignes entres chaques mois. merci

 

[job75]

Bonjour Nico_J, le forum,

Nous sommes le 11 avril, c'est bien le 10 avril qui doit être coloré, voici ma solution :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, mini&, ecart&, lig&
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("A2:A" & Rows.Count).Clear 'RAZ
If Val([A1]) Like "####" Then
    [A2] = DateSerial([A1], 1, 1) '1er janvier
    With [A2:A367]
        .NumberFormat = "ddd dd/mm/yyyy"
        .DataSeries
        If Day(.Cells(.Count)) = 1 Then .Cells(.Count).Delete xlUp
        For i = .Count To 1 Step -1
            If Weekday(.Cells(i)) < 3 Or Weekday(.Cells(i)) > 4 Then .Cells(i).Delete xlUp
        Next i
        For i = .Count To 2 Step -1
            If Month(.Cells(i)) > Month(.Cells(i - 1)) Then .Cells(i).Insert xlDown
        Next i
        mini = 9 ^ 9
        For i = 1 To .Count
            ecart = Abs(.Cells(i) - Date)
            If ecart < mini Then mini = ecart: lig = i
        Next i
        .Cells(lig).Interior.Color = vbCyan
    End With
End If
Application.EnableEvents = True 'réactive les évènements
End Sub

A+

 

[mapomme]

Re,

Ma première version modifiée pour passer de noir & blanc en couleur.
Suivant les types de jours retenus, il se peut qu'une cellule ou deux soient colorées.