Calcul automatique des n° de semaine

Soyez le premier à donner votre avis sur cette source.

Snippet vu 33 534 fois - Téléchargée 27 fois

Contenu du snippet

Code permettant de calculer de manière automatique les N° de semaine sur une période donnée.

Explication : 1 - J'ai une semaine qui sert de référence pour le calcul
2 - Depuis cette semaine de référence, je calcul le N° des semaines précédentes et suivantes
3 - Le nombre de semaine a calculer par rapport à la semaine de référence est une donnée paramètrable
4 - Quelque soit l'année, cela fonctionne
5 - Amélioration à venir : position de la semaine de référence va être paramètrable
6 - VBA fonctionnant en adéquation avec Microsoft Excel

Toutes remarques sera la bienvenue

Source / Exemple :


Public Function Semaine(dat As Date) As Integer
    Dim a As Integer
    a = Int((dat - DateSerial(Year(dat), 1, 1) + _
        ((Weekday(DateSerial(Year(dat), 1, 1)) + 1) _
        Mod 7) - 3) / 7) + 1
    If a = 0 Then
        a = Semaine(DateSerial(Year(dat) - 1, 12, 31))
    ElseIf a = 53 And (Weekday(DateSerial(Year(dat), 12, 31)) - 1) _
        Mod 7 <= 3 Then
        a = 1
    End If
    Semaine = a
End Function

Function WriteWeekAnnee()

Dim NomDuJour(7) As String
Dim StockVal()

LiRef = 3 'La ligne de référence où vont être inscrits la valeur des différentes semaines
Col_Sem_Ref = 6 'Par exemple la semaine de référence se trouve à la colonne N° 6
NB_Colonne_A_Traiter = 34 'Le N° de la dernière colonne à remplir est 30
Lib_Deb_Sem = 4 'N° de la colonne ou commence l'écriture des différentes semaines
Nb_Sem_Before = Col_Sem_Ref - Lib_Deb_Sem 'Nb de semaines avant la semaine de référence

DateActuel = Now
Num_Jour_Actuel = Day(Range("A3").Value) 
Num_Mois_Actuel = Month(Range("A3").Value)
Num_Year_Actuel = Year(Range("A3").Value)
Num_Jour_Sem_Actuel = Weekday(Range("A3").Value, vbUseSystem)

Sem_Ref = Val(Semaine(Range("A3").Value))

If Len(Sem_Ref) = 1 Then
   Range("B2").Value = "0" & Sem_Ref
Else
   Range("B2").Value = Sem_Ref
End If

NbTotSem = 52

LiDeb = Col_Sem_Ref - Nb_Sem_Before

Range(Cells(LiRef, LiDeb), Cells(LiRef, NB_Colonne_A_Traiter)).ClearContents 'On efface les anciennes valeurs

If Sem_Ref Is >= 52 Then
   Sem_Ref = 1
   Num_Year_Actuel = Num_Year_Actuel + 1
Else
   Sem_Ref = Sem_Ref + 1
   Num_Year_Actuel = Num_Year_Actuel
End Select

If Sem_Ref < 10 Then
   Cells(LiRef, Col_Sem_Ref).Value = "0" & Sem_Ref & "/" & Num_Year_Actuel
Else
   Cells(LiRef, Col_Sem_Ref).Value = Sem_Ref & "/" & Num_Year_Actuel
End If

Sem_Actuel = Semaine(CDate(Range("A3").Value))
Sem_Ref = Val(Left(Range("F3").Value, 2))
Annee_Actuel = Val(Year(Range("A3").Value))
Annee_Ref = Val(Right(Cells(LiRef, Col_Sem_Ref).Value, 4))

If Sem_Ref = 1 Then
   Select Case Annee_Ref
   Case Is <> Annee_Actuel
        Range("F3").Offset(0, -1).Value = NbTotSem & "/" & Annee_Ref - 1
        Range("F3").Offset(0, -2).Value = NbTotSem - 1 & "/" & Annee_Ref - 1
   Case Is = Num_Year_Actuel
        Range("F3").Offset(0, -1).Value = NbTotSem & "/" & Annee_Actuel - 1
        Range("F3").Offset(0, -2).Value = NbTotSem - 1 & "/" & Annee_Actuel - 1
   End Select
Else
   If Sem_Ref = 2 Then
      Range("F3").Offset(0, -1).Value = "0" & Sem_Ref - 1 & "/" & Annee_Actuel
      Range("F3").Offset(0, -2).Value = NbTotSem & "/" & Annee_Actuel - 1
   Else
      If Sem_Ref >= 3 And Sem_Ref < 12 Then
         Select Case Sem_Ref
                Case Is <= 10
                     Range("F3").Offset(0, -1).Value = "0" & Sem_Ref - 1 & "/" & Num_Year_Actuel
                     Range("F3").Offset(0, -2).Value = "0" & Sem_Ref - 2 & "/" & Num_Year_Actuel
                Case 11
                     Range("F3").Offset(0, -1).Value = Sem_Ref - 1 & "/" & Num_Year_Actuel
                     Range("F3").Offset(0, -2).Value = "0" & Sem_Ref - 2 & "/" & Num_Year_Actuel
         End Select
      Else
         Range("F3").Offset(0, -1).Value = Sem_Ref - 1 & "/" & Num_Year_Actuel
         Range("F3").Offset(0, -2).Value = Sem_Ref - 2 & "/" & Num_Year_Actuel
      End If
   End If
End If
   
NBIteration = NbTotSem - Left((Cells(LiRef, Col_Sem_Ref).Value), 2)
  
If NBIteration > NB_Colonne_A_Traiter - Col_Sem_Ref Then '24
   NBIteration = NB_Colonne_A_Traiter - Col_Sem_Ref
Else
  If NBIteration = 0 Then
     NBIteration = NB_Colonne_A_Traiter - Col_Sem_Ref
     Sem_Actuel = 0
  Else
     NBIteration = NBIteration
  End If
End If

ReDim StockVal(NBIteration) 'On réalloue de manière dynamique le nbre d'éléments à stocker
  
Val_Sem_Ref = Val(Left((Cells(LiRef, Col_Sem_Ref).Value), 2))
  
If Val_Sem_Ref = NbTotSem Then
   Num_Year_Actuel = Num_Year_Actuel + 1
Else
   Num_Year_Actuel = Num_Year_Actuel
End If

For I = 1 To NBIteration
    Sem_Ref = Sem_Ref + 1
    If Len(Sem_Ref) > 1 Then
       Range("F3").Offset(0, I).Value = Sem_Ref & "/" & Num_Year_Actuel
    Else
       Range("F3").Offset(0, I).Value = "0" & Sem_Ref & "/" & Num_Year_Actuel
    End If
    StockVal(1) = Range("F3").Offset(0, I).Value
Next I
  
Val_Find = StockVal(1)
ValCelSem = Cells.Find(Val_Find, , , , xlByColumns, xlPrevious).Column
AdCelSem = Cells.Find(Val_Find, , , , xlByColumns, xlPrevious).Address
NewYear = Right(Range(adCelSem), 4) + 1
NBIteration = NB_Colonne_A_Traiter - ValCelSem
   
For I = 1 To NBIteration
    If Len(I) = 1 Then
       Sem_Actuel = I
       Range(adCelSem).Offset(0, I).Value = "0" & Sem_Actuel & "/" & NewYear
    Else
       Sem_Actuel = I
       Range(adCelSem).Offset(0, I).Value = Sem_Actuel & "/" & NewYear
    End If
Next I
 
End Function

A voir également

Ajouter un commentaire

Commentaires

PCPT
Messages postés
13281
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
30
utilise plutôt le forum pour poser ce genre de question, elle n'a pas de rapport avec la source. merci
jodeciters
Messages postés
7
Date d'inscription
vendredi 26 décembre 2008
Statut
Membre
Dernière intervention
16 mars 2009

Bonjour à tous,

Béotien je bricole un programme et je souhaite que les lignes triées (dont une colonne fait apparaître la date du jour), apparaisent de couleurs différentes en fonction des semaines paires et impaires.
J'ai bien trouvé différentes propositions mais je ne sais pas comment on fait le lien entre une macro qui commence par:
Sub ()
et les exemples donnés qui commencent par "Public Function"
merci pour votre aide
SASC01
Messages postés
1
Date d'inscription
mardi 18 septembre 2007
Statut
Membre
Dernière intervention
18 septembre 2007

Bonjour,

semaine = DatePart(DateInterval.WeekOfYear, Now) semble fonctionner !
Kristof_Koder
Messages postés
918
Date d'inscription
vendredi 3 août 2007
Statut
Membre
Dernière intervention
27 octobre 2008
9
Il est ou le bug de la fonction no.semaine de Excel ? avec le 29/12/2007, j'obtient 52 ! Cela me parait juste ! Non ?
fpetit25
Messages postés
1
Date d'inscription
mardi 21 novembre 2006
Statut
Membre
Dernière intervention
7 décembre 2006

Bonjour,

Je pense que la plupart des personnes n'ont pas compris à quoi cela servait. Ce code permet d'écrire les N° de semaine dans des cellules d'excel avec l'année correspondante et non pas calculer juste le N° des semaines sinon le code aurait fait que quelques lignes. De plus la fonction dans excel no.semaine à un bug (faites un test du 29/12/2007 !!!).
Maintenant je l'ai optimisé et il ne fait plus que 50 lignes.

Merci pour toutes ces remarques.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.