Microsoft 365 MACRO Remplacer date si jour non ouvré remplace par jour ouvré précédent

chris6999 · 16 Janvier 2023

Bonjour

Je cherche un code qui passerait sur une plage de dates (ColB) et qui, si la date est un jour non ouvré, remplace par le 1er jour ouvré précédent.
Ex si date correspond à un samedi ou un dimanche remplace par la date du vendredi.
SI jour férié vendredi remplace par jeudi.

Le but est de traiter la colonne directement et de ne pas utiliser les autres colonnes.

Merci par avance pour votre aide.

Bonne journée

JHA · 16 Janvier 2023

Bonjour à tous,

Un début de piste par formule, à toi de retranscrire en VBA car je ne sais pas faire.

JHA

sylvanu · 16 Janvier 2023

Bonjour Chris, JHA,
Un essai en PJ avec :

VB:

Sub SupprimeWE()
    Dim L%
    Application.ScreenUpdating = False
    For L = 7 To Range("B65500").End(xlUp).Row
        Select Case Weekday(Cells(L, "B"), vbMonday)
            Case 6: Cells(L, "B") = Cells(L, "B") - 1
            Case 7: Cells(L, "B") = Cells(L, "B") - 2
        End Select
    Next L
End Sub

JHA · 16 Janvier 2023

Bonjour @sylvanu

Cela parait tellement simple avec VBA
Il te manque l'option des fériés dans ton exemple.

JHA

sylvanu · 16 Janvier 2023

Oups, j'avais zappé. Merci JHA.
Un PJ 2 avec :

VB:

Sub SupprimeWE()
    Dim L%
    [P1] = Year([B7])   ' Met à jour l'année pour le calcul des jours fériés.
    Application.ScreenUpdating = False
    For L = 7 To Range("B65500").End(xlUp).Row
        Select Case Weekday(Cells(L, "B"), vbMonday)
            Case 6:
                Cells(L, "B") = Cells(L, "B") - 1
            Case 7: Cells(L, "B") = Cells(L, "B") - 2
        End Select
        If Application.CountIf([Férié], Cells(L, "B")) > 0 Then
            Cells(L, "B") = Application.Index([Remplacé], Application.Match(Cells(L, "B"), [Férié], 0))
        End If
    Next L
End Sub

J'ai mis la liste des fériés sur 2 ans si la liste des dates est à cheval.

chris6999 · 17 Janvier 2023

sylvanu à dit:

Bonjour Chris, JHA,
Un essai en PJ avec :

VB:

Sub SupprimeWE()
    Dim L%
    Application.ScreenUpdating = False
    For L = 7 To Range("B65500").End(xlUp).Row
        Select Case Weekday(Cells(L, "B"), vbMonday)
            Case 6: Cells(L, "B") = Cells(L, "B") - 1
            Case 7: Cells(L, "B") = Cells(L, "B") - 2
        End Select
    Next L
End Sub

Bonjour et merci Sylvanu.
Cela fonctionne nickel et en plus le traitement est très rapide
Je vais essayer d'adapter le code à mon projet.

Bonne journée

chris6999 · 17 Janvier 2023

JHA à dit:
Bonjour à tous,

Un début de piste par formule, à toi de retranscrire en VBA car je ne sais pas faire.

JHA

Merci pour ta proposition mais c'est bien le code que je recherchais car je connais déjà les fonctions pour le faire.
Pour retranscrire en VBA tu peux enregistrer ta formule en macro, c'est un bon début pour apprendre
Bonne journée

sylvanu · 17 Janvier 2023

chris6999 à dit:
Je vais essayer d'adapter le code à mon projet.

Sorry il y a un petit bug dans la version V2 concernant la pentecôte et le lundi de pentecôte.

Donc voici une nouvelle version, tout en VBA ( la liste des fériés dans la page me "dérangeait"
La macro utilise deux fonctions perso ( dans le module GereJoursFeries )
1- JourFérié(Madate) revoie vide si non férié, renvoie une chaine si férié.
2- JourOuvréAprèsJourFérié(MaDate) renvoie le même jour si non férié, sinon Madate-1 ou -3 si férié.
Donc dans votre dossier il faut importer les deux modules GereJoursFeries et SupprimeWeekEnd
Sur mon PC, cela gère tout 2023 en 40ms.

Microsoft 365 MACRO Remplacer date si jour non ouvré remplace par jour ouvré précédent

chris6999

XLDnaute Impliqué

Pièces jointes

JHA

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

JHA

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Pièces jointes

chris6999

XLDnaute Impliqué

chris6999

XLDnaute Impliqué

sylvanu

XLDnaute Barbatruc

Pièces jointes

Discussions similaires