VBA PB n° de semaine

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Arpette
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
A

Arpette

XLDnaute Impliqué
Bonjour le forum, j'ai un problème avec mon n° de semaine. Nous somme le 1/08/2010 et en semaine 31, ma formule affiche 30. Je ne comprends pas.Ci-joint mon code.
Merci de votre aide

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False

Dim Sme As Byte

Sme = DatePart("ww", Date, 2, 2)
Cells(1, 1) = "Semaine n° " & Sme

datedep = CDate("1/1/" & Year(Date))
For D = datedep To CDate("1/1/" & Year(Date) + 1)
If DatePart("ww", D, 2, 2) = Sme Then
Cells(2, 1) = "Du " & D & " au " & D + 6
Exit For
End If
Next
Application.ScreenUpdating = True
End Sub
 
Trier par date Trier par votes
Re : VBA PB n° de semaine

ROGER2327 à dit:
Re...
Je dois dire que j'ai un peu de mal à vous suivre car, si vous utilisez le calendrier ISO, vous ne pourrez pas avoir de référence exacte aux mois du calendrier grégorien (la notion de mois n'existe pas dans le calendrier ISO).
En pratique, les semaines extrêmes couvrant un mois du calendrier grégorien "débordent" généralement sur le mois précédent et le mois suivant. C'est le cas pour le mois d'août 2010, puisque la semaine contenant le premier août débute le 26 juillet, et la semaine contenant le 31 août s'achève le 5 septembre.

Il n'y a qu'en février, certaines années, que la correspondance peut être exacte. Par exemple en 2010 :
2010W05-1 Sem.n° 05 Du lun. 01-02-2010 au dim. 07-02-2010
2010W06-1 Sem.n° 06 Du lun. 08-02-2010 au dim. 14-02-2010
2010W07-1 Sem.n° 07 Du lun. 15-02-2010 au dim. 21-02-2010
2010W08-1 Sem.n° 08 Du lun. 22-02-2010 au dim. 28-02-2010

Pour ce qui est de votre classeur, je ne peux l'étudier : je prends quelques jours de vacances à compter d'aujourd'hui. J'espère que d'autres vous donneront un coup de main...
À plus tard, donc, et bon courage.​
ROGER2327
#3997

Samedi 21 Tatane 137 (Saints Catoblepas, lord et Anoblepas, amirals, SQ)
16 Thermidor An CCXVIII
2010-W31-2T00:53:22Z
Cliquez pour agrandir...

Bonjour à tous, je reposte si quelqu'un peut m'aider.
D'avance merci.
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

Arpette,
Fait cette rectif en Open pour les N°Sem
Par contre tous mes essais mettent bien la bonne année en ayant supprimé le If cells(4,1)=Empty et le end if.
Bruno
Code: 
    For Each c In Range("C1,E1,G1,I1,K1")
        
        j = d + 1 - DatePart("w", d, vbMonday, vbFirstFourDays)
        c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
        d = d + 7 'DateDepart = DateDepart + 7     'Incrémente la date de 7 jours (1 semaine)
        
    Next
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
Arpette,
Fait cette rectif en Open pour les N°Sem
Par contre tous mes essais mettent bien la bonne année en ayant supprimé le If cells(4,1)=Empty et le end if.
Bruno
Code: 
    For Each c In Range("C1,E1,G1,I1,K1")
        
        j = d + 1 - DatePart("w", d, vbMonday, vbFirstFourDays)
        c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
        d = d + 7 'DateDepart = DateDepart + 7     'Incrémente la date de 7 jours (1 semaine)
        
    Next
Cliquez pour agrandir...
Salut Bruno, merci çà fonctionne dans tous les cas avec ou sans semaine53. J'au une autre question, comment faire à l'envoi d'un code d'avoir une présentation comme la tienne.
Merci pour ton aide.
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

c'est bien facile,
J'écris mon texte sans la macro
Aller en mode avancé et place ton curseur à la fin
click sur l'icone # (code)
tu auras comme ceci
Code: 
je colle la macro ici entre les 2 [code]
[CODE]
Bruno
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
c'est bien facile,
J'écris mon texte sans la macro
Aller en mode avancé et place ton curseur à la fin
click sur l'icone # (code)
tu auras comme ceci
Code: 
je colle la macro ici entre les 2 [code]
[CODE]
Bruno[/QUOTE]
Re, Bruno je fais un test, çà n'a pas l'air de marcher.
#
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Worksheets("Relevé_Hebdo").Unprotect
 
Sheets("Récap_Mensuelle").Select
If Cells(4, 1) = Empty Then
 
Dim mois As String
Dim Année As String
Dim Titre As String
Dim Récap_Mensuelle As String
Dim Relevé_Hebdo As String
Dim Semaine As String
Dim Sme As String
Dim c As Range
Dim DateDepart As Date
Dim D As Date
Dim j As Date
'Date départ au 1er du mois
DateDepart = DateSerial(Year(Date), Month(Date), 1)
 
D = Date
j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
mois = Format(j + 3, "mmmm") 'mois contenant au moins 4 jours de la semaine.
Année = Format(DateDepart, "yyyy")
 
Titre = "MOIS DE" & " " & mois & " " & Année
Cells(4, 1) = UCase(Titre)
 
Sheets("Relevé_Hebdo").Select
Worksheets("Relevé_Hebdo").Unprotect
mois = Format(j + 3, "mmmm")
Année = Format(Now, "yyyy")
 
Titre = "MOIS DE" & " " & mois & " " & Année
Cells(1, 1) = UCase(Titre)
 
For Each c In Range("C1,E1,G1,I1,K1")
 
j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
D = D + 7 'DateDepart = DateDepart + 7 'Incrémente la date de 7 jours (1 semaine)
 
Next
Worksheets("Relevé_Hebdo").Protect
End If
Application.ScreenUpdating = True
 
End Sub
 
#
Cliquez pour agrandir...
 
Dernière édition:
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

Re,
En bas tu as le bouton "Envoyer" et à droite le bouton "aller en mode avancé"
click de suite sur ce dernier bouton et là tu verras l'icone . . . . #
Tu peux aussi faire une "Prévisualisation"
Fait des tests même sans envoyer
Bruno
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
Re,
En bas tu as le bouton "Envoyer" et à droite le bouton "aller en mode avancé"
click de suite sur ce dernier bouton et là tu verras l'icone . . . . #
Tu peux aussi faire une "Prévisualisation"
Fait des tests même sans envoyer
Bruno
Cliquez pour agrandir...
Re, je n'ai pas le bouton "aller en mode avancé" juste envoyer réponse et prévisualisation du message.
Code: 
C'est bon j'ai trouvé, merci Bruno.
@+
 
Dernière édition:
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
Arpette,
Fait cette rectif en Open pour les N°Sem
Par contre tous mes essais mettent bien la bonne année en ayant supprimé le If cells(4,1)=Empty et le end if.
Bruno
Code: 
    For Each c In Range("C1,E1,G1,I1,K1")
        
        j = d + 1 - DatePart("w", d, vbMonday, vbFirstFourDays)
        c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
        d = d + 7 'DateDepart = DateDepart + 7     'Incrémente la date de 7 jours (1 semaine)
        
    Next
Cliquez pour agrandir...

Je viens de m'apercevoir que si je mets la date système au 9/08/2010, les semaines qui s'affichent dans dans mes cellules sont 32,33,34,35,36. Est-il possible de garder la date de début de mois pour avoir 31,32,33,34,35
Merci de votre aide.
 
Dernière édition:
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
Arpette,
Comme je constate que tu es pressé je n'ai pas testé

d = CVDate("01/" & Month(Date) & "/" & Year(Date))
au lieu de
d = Date
Bruno
Cliquez pour agrandir...

Bonsoir Bruno, non je ne suis pas pressé, seulement peur que l'on m'oublie. J'ai procédé autrement dis moi ce que tu en penses. Par contre il me reste un problème d'où mon nouveau post concernant la dateDepart qui tombe un dimanche. Si la date système est le 01/08/2010 je suis au mois de Juillet et les semaines ne correspondent plus. Cest pourquoi dans mon nouveau post, je souhaite que si le premier est un dimanche DateDepart = le mois précédant. J'espère que ce que je demande est compréhensible. En tous les cas merci pour toute ton aide.

Code: 
Private Sub Workbook_Open()
Worksheets("Relevé_Hebdo").Unprotect

Sheets("Récap_Mensuelle").Select
    If Cells(4, 1) = Empty Then

    Dim mois As String
    Dim Année As String
    Dim Titre As String
    Dim Récap_Mensuelle As String
    Dim Relevé_Hebdo As String
    Dim Semaine As String
    Dim Sme As String
    Dim c As Range
    Dim DateDepart As Date
    Dim D As Date
    Dim j As Date
    Dim k As Date
    'Date départ au 1er du mois
    DateDepart = DateSerial(Year(Date), Month(Date), 1)
    k = DateDepart
        If Weekday(k, 2) = 7 Then
        k = DateAdd("m", -1, k)
        Else
        k = DateDepart
        End If
    D = Date
    j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
    mois = Format(j + 3, "mmmm") 'mois contenant au moins 4 jours de la semaine.
    Année = Format(DateDepart, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(4, 1) = UCase(Titre)

    Sheets("Relevé_Hebdo").Select
    Worksheets("Relevé_Hebdo").Unprotect
    mois = Format(j + 3, "mmmm")
    Année = Format(Now, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(1, 1) = UCase(Titre)
        If D > k Then
            D = k + 1
            Else
            D = D
        End If
            For Each c In Range("C1,E1,G1,I1,K1")
        
                j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
                c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
                D = D + 7 'DateDepart = DateDepart + 7     'Incrémente la date de 7 jours (1 semaine)
        
            Next
        Worksheets("Relevé_Hebdo").Protect
    End If
    
End Sub
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

Bonsoir,
Mes tests sont bon mais je t'invite à en faire d'autres.
Voici déja ma derniere version.
J'ai aussi une autre méthode plus simple pour trouver le lundi mais je dois encore voir
je la ferai si j'ai le temps
Bruno
Code: 
Private Sub Workbook_Open()
    Dim mois As String
    Dim Année As String
    Dim Titre As String
    Dim Récap_Mensuelle As String
    Dim Relevé_Hebdo As String
    Dim Semaine As String
    Dim Sme As String
    Dim c As Range
    Dim DateDepart As Date
    Dim D As Date
    Dim j As Date
    Dim k As Date
    
    Sheets("Récap_Mensuelle").Select
    If Cells(4, 1) = Empty Then
    'Date départ au 1er du mois
'pour tester une autre date que la date du jour exemple    k="04/10/2010"
    k = Date
    DateDepart = DateSerial(Year(k), Month(k), 1)
    k = DateDepart
        If Weekday(k, 2) = 7 Then k = k + 1
        
    D = k
    j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
    mois = Format(j + 3, "mmmm") 'mois contenant au moins 4 jours de la semaine.
    Année = Format(k, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(4, 1) = UCase(Titre)

    Sheets("Relevé_Hebdo").Select
    Worksheets("Relevé_Hebdo").Unprotect
    mois = Format(j + 3, "mmmm")
    Année = Format(Now, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(1, 1) = UCase(Titre)
        If D > k Then
            D = k + 1
            Else
            D = D
        End If
            For Each c In Range("C1,E1,G1,I1,K1")
                j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
                c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
                D = D + 7    'Incrémente la date de 7 jours (1 semaine)
            Next
        Worksheets("Relevé_Hebdo").Protect
    End If
End Sub
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

J'ai remodifié
Bruno
Code: 
Private Sub Workbook_Open()
    Dim mois As String
    Dim Année As String
    Dim Titre As String
    Dim Récap_Mensuelle As String
    Dim Relevé_Hebdo As String
    Dim Semaine As String
    Dim Sme As String
    Dim c As Range
    Dim DateDepart As Date
    Dim D As Date
    Dim j As Date
    Dim k As Date
    Sheets("Récap_Mensuelle").Select
    If Cells(4, 1) = Empty Then
    'Date départ au 1er du mois
'pour tester une autre date que la date du jour exemple    k="04/10/2010"
    D = "03/01/2010" 'Date
    k = D
    DateDepart = DateSerial(Year(D), Month(D), 1)
    D = DateDepart
        If Weekday(D, 2) = 7 Then D = D + 1
        
    j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
    mois = Format(k, "mmmm") 'mois contenant au moins 4 jours de la semaine.
    Année = Format(k, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(4, 1) = UCase(Titre)

    Sheets("Relevé_Hebdo").Select
    Worksheets("Relevé_Hebdo").Unprotect
    mois = Format(k, "mmmm")
    Année = Format(k, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(1, 1) = UCase(Titre)
            For Each c In Range("C1,E1,G1,I1,K1")
                j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
                c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
                D = D + 7    'Incrémente la date de 7 jours (1 semaine)
            Next
        Worksheets("Relevé_Hebdo").Protect
    End If
    
End Sub
 
Vote positif 0 Vote négatif
Re : VBA PB n° de semaine

youky(BJ) à dit:
J'ai remodifié
Bruno
Code: 
Private Sub Workbook_Open()
    Dim mois As String
    Dim Année As String
    Dim Titre As String
    Dim Récap_Mensuelle As String
    Dim Relevé_Hebdo As String
    Dim Semaine As String
    Dim Sme As String
    Dim c As Range
    Dim DateDepart As Date
    Dim D As Date
    Dim j As Date
    Dim k As Date
    Sheets("Récap_Mensuelle").Select
    If Cells(4, 1) = Empty Then
    'Date départ au 1er du mois
'pour tester une autre date que la date du jour exemple    k="04/10/2010"
    D = "03/01/2010" 'Date
    k = D
    DateDepart = DateSerial(Year(D), Month(D), 1)
    D = DateDepart
        If Weekday(D, 2) = 7 Then D = D + 1
        
    j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
    mois = Format(k, "mmmm") 'mois contenant au moins 4 jours de la semaine.
    Année = Format(k, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(4, 1) = UCase(Titre)

    Sheets("Relevé_Hebdo").Select
    Worksheets("Relevé_Hebdo").Unprotect
    mois = Format(k, "mmmm")
    Année = Format(k, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(1, 1) = UCase(Titre)
            For Each c In Range("C1,E1,G1,I1,K1")
                j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
                c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
                D = D + 7    'Incrémente la date de 7 jours (1 semaine)
            Next
        Worksheets("Relevé_Hebdo").Protect
    End If
    
End Sub
Cliquez pour agrandir...

Bonsoir Bruno et merci pour ton aide, je n'ai pas bien compris tester sur autre date, ça fonctionne mais je dois rentrer une date, je souhaite la date système. J'ai écris ce code, dis moi si c'est correcte, pour moi çà marche: Explication:
Si date système = DateDepart et que date système est Dimanche alors DateDepart = mois précédent sinon DateDepart.
C'est le cas pour le 1er Août
@+
Code: 
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Worksheets("Relevé_Hebdo").Unprotect

Sheets("Récap_Mensuelle").Select
If Cells(4, 1) = Empty Then

    Dim mois As String
    Dim Année As String
    Dim Titre As String
    Dim Récap_Mensuelle As String
    Dim Relevé_Hebdo As String
    Dim Semaine As String
    Dim Sme As String
    Dim c As Range
    Dim DateDepart As Date
    Dim D As Date
    Dim j As Date
    Dim k As Date
    'Date départ au 1er du mois
    DateDepart = DateSerial(Year(Date), Month(Date), 1)
    k = DateDepart
    D = Date
        If D <> k Then
          ElseIf Weekday(D) = vbSunday Then
            k = DateAdd("m", -1, k)
          Else
            k = DateDepart
        End If


    D = Date
    j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
    mois = Format(j + 3, "mmmm") 'mois contenant au moins 4 jours de la semaine.
    Année = Format(DateDepart, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(4, 1) = UCase(Titre)

    Sheets("Relevé_Hebdo").Select
    Worksheets("Relevé_Hebdo").Unprotect
    mois = Format(j + 3, "mmmm")
    Année = Format(Now, "yyyy")

    Titre = "MOIS DE" & " " & mois & " " & Année
    Cells(1, 1) = UCase(Titre)
        If D > k Then
            D = k + 1
            Else
            D = D
        End If
            For Each c In Range("C1,E1,G1,I1,K1")
        
                j = D + 1 - DatePart("w", D, vbMonday, vbFirstFourDays)
                c = "Sem " & DatePart("ww", j, vbMonday, vbFirstFourDays)
                D = D + 7 'DateDepart = DateDepart + 7     'Incrémente la date de 7 jours (1 semaine)
        
            Next
        Worksheets("Relevé_Hebdo").Protect
   End If
   
    Application.ScreenUpdating = True

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

PORCHER
  • Question Question
Microsoft 365 Problème de date
Réponses
5
Affichages
169
AtTheOne
AtTheOne
F
  • Résolu(e)
Autres Insérer une ligne
2 3
Réponses
36
Affichages
2 K
francescofrancesco
F
U
  • Question Question
Autres [RÉSOLU] Compléter la macro mais comment et où?
Réponses
2
Affichages
258
un internaute
U
W
  • Résolu(e)
XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C
2
Réponses
26
Affichages
440
Webperegrino
W
P
  • Question Question
Microsoft 365 VBA et Segments TCD
Réponses
2
Affichages
212
patricko-13
P
Nicolas JACQUIN
  • Question Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
854
TooFatBoy
TooFatBoy
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
697
Gestionnaire_rh
G
B
  • Question Question
Microsoft 365 Macro pour création fichier csv
Réponses
8
Affichages
485
job75
job75
A
  • Question Question
XL pour MAC Problème avec une macro dupliquant une feuille contenant une macro
Réponses
8
Affichages
151
AlineJ
A
J
  • Question Question
XL 2021 transfert listview vers feuille excel
Réponses
9
Affichages
341
Piment
P
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
183
CDALE
C
thunder23
  • Résolu(e)
XL 2021 Bug dans code vba
Réponses
8
Affichages
331
thunder23
thunder23
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
Nicolas JACQUIN
richardlion
  • Question Question
XL 2016 annulation ou désactivation de macro
2
Réponses
27
Affichages
583
job75
job75
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
407
vgendron
vgendron
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
269
KRUG WOO
K
A
  • Question Question
XL 2019 Copie d'une valeur dans la cellule à côté d'une valeur trouvé
Réponses
1
Affichages
159
sylvanu
sylvanu
B
  • Question Question
XL 2019 Dans une macro de démarrage de fichier masquer le code par des Astérix ou point
Réponses
3
Affichages
213
sylvanu
sylvanu
A
  • Question Question
XL 2010 Filtrer un Combobox en VBA excel
2 3
Réponses
43
Affichages
942
Dranreb
Dranreb
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
523
CortoXls
C
Retour