XL 2016 Condition avec reprise de date antérieurs

VBA · 7 Mai 2018

Bonjour,

J'ai un petit programme vba qui tourne pour lancer des extractions de la semaine d'avant via l'erp de l'entreprise et j'ai mis en place une boucle qui me permet de prendre le lundi de la semaine d'avant jusqu''au vendredi de la semaine d'avant.
C'est un calcul tout simple qui prend le jour actuel et qui le soustrait au nombre de jour qu'il faut pour arrivé au lundi de la semaine d'avant. Il fait la même chose pour le vendredi.
Mon problème est le suivant c'est qu'en début de mois si je lance l'extraction aujourdhui soit le lundi 07 mai il doit aller chercher le lundi 30 Avril chose qu'il ne fait pas, il va rentre 00/05/2018.
Je voudrais savoir si vous pouvez m'aider pour une petite boucle qui prend en compte le mois et moi renvoi la date correcte.
Voici le code ci dessous.
Merci.

VB:

dim d 'date à traiter
dim stJs ' chaine jour de la semaine..
d = now ' date actuelle
stJS = WeekDayName(WeekDay(d))

If stJS = "lundi" Then
    jour = Day(Now) - 7 & "." & Month(Now) & "."  & Year(Now)
    jour2 = Day(Now) - 3 & "." &  Month(Now) & "." & Year(Now)
ElseIf stJS = "mardi" Then
    jour = Day(Now) - 8 & "." & Month(Now) & "."  & Year(Now)
    jour2 = Day(Now) - 4 & "." &  Month(Now) & "." & Year(Now)
ElseIf stJS = "mercredi" Then
    jour = Day(Now) - 9 & "." & Month(Now) & "."  & Year(Now)
    jour2 = Day(Now) - 5 & "." &  Month(Now) & "." & Year(Now)
ElseIf stJS = "jeudi" Then
    jour = Day(Now) - 10 & "." & Month(Now) & "."  & Year(Now)
    jour2 = Day(Now) - 6 & "." &  Month(Now) & "." & Year(Now)
ElseIf stJS = "vendredi" Then
    jour = Day(Now) - 11 & "." & Month(Now) & "."  & Year(Now)
    jour2 = Day(Now) - 7 & "." &  Month(Now) & "." & Year(Now)
End IF

Rouge · 7 Mai 2018

Bonjour,
Essayez ceci

Dim d 'date à traiter
Dim stJs ' chaine jour de la semaine..
d = Now ' date actuelle
stJs = WeekdayName(Weekday(d), , 1)

If stJs = "lundi" Then
jour = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 7)
jour2 = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 3)
ElseIf stJs = "mardi" Then
jour = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 8)
jour2 = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 4)
ElseIf stJs = "mercredi" Then
jour = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 9)
jour2 = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 5)
ElseIf stJs = "jeudi" Then
jour = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 10)
jour2 = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 6)
ElseIf stJs = "vendredi" Then
jour = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 11)
jour2 = CDate(CDate(Day(Now) & "/" & Month(Now) & "/" & Year(Now)) * 1 - 7)
End If

Cdlt

VBA · 7 Mai 2018

Sa fonctionne bien mais le seul problème c'est que l'erp il accepte la date sous format xx.xx.xxxx et non xx/xx/xxxx.
Et quand je fais le changement sa m'indique une erreur d'incompatibilité avec le CDate.

Rouge · 7 Mai 2018

RE,
Ajoutez ces 2 lignes après le "End if"
Jour = Replace(Jour, "/", ".")
Jour2 = Replace(Jour2, "/", ".")
Cdlt

VBA · 7 Mai 2018

Merci ça marche parfaitement

Staple1600 · 7 Mai 2018

Bonjour le fil, Re VBA, Rouge

Une petite fonction personnalisée qui pourrait avoir son utilité ici.
(ci-dessous la fonction et des exemples basiques d'emploi)
NB: JOURPOUS pour JOURPrécédentOUSuivant

VB:

Sub Exemples_Utilisation()
'lundi et vendredi précédents aujourd'hui
MsgBox JOURPOUS(Date, -1, vbMonday)
MsgBox JOURPOUS(Date, -1, vbFriday)

'lundi et vendredi suivants aujourd'hui
MsgBox JOURPOUS(Date, 1, vbMonday)
MsgBox JOURPOUS(Date, 1, vbFriday)
End Sub
Private Function JOURPOUS(j As Date, PlusMoins As Integer, jsem As VbDayOfWeek)
JOURPOUS = DateAdd("ww", PlusMoins, j - (Weekday(j)) + jsem)
End Function

VBA · 9 Mai 2018

Effectivement elle est très pratique. Merci @Staple1600

XL 2016 Condition avec reprise de date antérieurs

VBA

XLDnaute Nouveau

Rouge

XLDnaute Impliqué

VBA

XLDnaute Nouveau

Rouge

XLDnaute Impliqué

VBA

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

VBA

XLDnaute Nouveau

Discussions similaires