Accueil > > > CALCUL AUTOMATIQUE DES N° DE SEMAINE
CALCUL AUTOMATIQUE DES N° DE SEMAINE
Information sur la source
Description
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
- 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
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
Historique
- 07 décembre 2006 05:09:54 :
- Rien de plus sinon que cela fonctionne quelque soit le jour de l'année.
Mon nouveau code est bientôt prêt et il ne fait plus que 50 lignes, défit à celui qui arrive à faire la même chose mais en plus court (je suis preneur).
Sources du même auteur
Sources de la même categorie
Commentaires et avis
Discussions en rapport avec ce code source dans le forum
vba sous exceel - calcul simple mais je connais pas - assez pressé [ par sonexopteor ]
Bonjour, je suis debutant total en programmationJe souhaite sous ecxcel effectué un calcul sur des données. J'ai deux colonnes, dans la première des d
VBA - ACCESS : Faire apparaître le jour de la semaine dans une date [ par kharrat ]
Salut,J'ai un champ de texte dans une table qui est en réalité une date (ne me demandez pas pourquoi, c'est pas moi qui est conçu l'appli ... ) au for
[VBA] Identifier une date la + proche de fin de mois [ par altarez ]
Bonjour à tous,Voila, je cherche un code VBA qui identifie parmis un liste de date, celle qui se rapporche le plus de la fin du mois.voici comment se
Graph sous VBA [ par jack bauer 57070 ]
Bonjour, <p class="MsoNormal" st
jour de semaine et date [ par thegrenouille ]
Bonjour,Voilà mon problème : je voudrai connaître le jour de la semaine correspondant à une date donnée.Exemple : lje donne l
calcul de jours entre deux date [ par mell01 ]
bonjours,qql saurait-il calculé le nb de jour entre deux dates, soit avec une fction sql ou une fonction vba?merci d'avance
----===BESOIN AIDE Au bord du GOUFFRE REQUETE repondez plz [ par boaconsaxor ]
Bonjour a tous et merci pour vos reponses...J'ai un probleme avec des requete sous access.En fait je dois faire une base de donnée avec ub formul
Interface en VBA visible avant la feuille de calcul ?? [ par jpsonza ]
Salut les forumeurs,Enkor moi et mes kestions stupides: Ya-t-il un moyen de faire apparaitre une interface (useform) Crée en VBA dès l'ouver
calcul de date [ par DarkRider26 ]
Bonjour à tous !!!Je souhaite faire un petit calcule sur des dates. En fait l'utilisateur choisira dans une liste défilante l'un des douze m
VB numéro de semaine jour et date [ par gothar12 ]
Bonjourje dispose de 2 combobox et d'un champ textLa 1ere combobox correspond au numéro de semaine de l'année (donc de 1 a 52) et la 2eme correspond a
|
Derniers Blogs
SESSION SILVERLIGHT 5 3D : SLIDES ET DEMOSSESSION SILVERLIGHT 5 3D : SLIDES ET DEMOS par Groc
Durant les techdays, j'ai eu le plaisir d'animer une session sur Silverlight 5 et la 3D avec Simon Ferquel. Comme promis, voici nos slides et mes démos (celles avec le viper BSG) ici et là. Pour mémoire, les démos utilisent toutes le viper BSG...
Cliquez pour lire la suite de l'article par Groc [TECHDAYS 2012] SESSION WEBMATRIX 2 : LE COUTEAU SUISSE GRATUIT POUR VOS DéVELOPPEMENTS WEB - SLIDES[TECHDAYS 2012] SESSION WEBMATRIX 2 : LE COUTEAU SUISSE GRATUIT POUR VOS DéVELOPPEMENTS WEB - SLIDES par gpommier
Suite à la session que j'ai présenté sur WebMatrix 2, vous pouvez trouver les slides ici, ainsi que les démos en packages nuget : démos1 et démos2 J'en profite pour remercier chaleureusement tous ceux qui sont venus très nombreux à cette sess...
Cliquez pour lire la suite de l'article par gpommier [SHAREPOINT] LES SESSIONS TECHDAYS 2012.[SHAREPOINT] LES SESSIONS TECHDAYS 2012. par Patrick Guimonet
Voici donc pour ceux qui n'ont pas pu venir, ou ceux qui n'ont pas pu toutes les suivre la liste des sessions SharePoint aux TechDays 2012, que je mettrais à jour dès que les liens des vidéo seront disponibles. Ou ici : http...
Cliquez pour lire la suite de l'article par Patrick Guimonet TECHDAYS PARIS 2012 : SESSION PLEINIèRE JOUR 3TECHDAYS PARIS 2012 : SESSION PLEINIèRE JOUR 3 par ROMELARD Fabrice
Speaker: Bernard Ourghanlian Cette session est comme chaque jour transmise en live par BrainSonic, et j'ai donc suivi cette troisième pleinière par ce moyen sur mon iPad . Elle est dédiée comme chaque année à la mise en perspective de l'é...
Cliquez pour lire la suite de l'article par ROMELARD Fabrice MISHRA READER : UN LECTEUR RSS TRèS ZUNE STYLE EN OPEN SOURCE !MISHRA READER : UN LECTEUR RSS TRèS ZUNE STYLE EN OPEN SOURCE ! par Vko
Hier durant une session dédiée aux Techdays 2012, j'ai eu le plaisir d'annoncer la sortie de la Béta 2 de Mishra Reader. C'est quoi ? Pour les utilisateurs, c'est une vraie expérience de lecture de flux RSS sur Windows. Rien à voir avec les produit...
Cliquez pour lire la suite de l'article par Vko
Logiciels
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)PONAMEDIA TV DEVIENS HELLLOOO FLASH
LA TV SUR VOTRE ORDINATEUR.
Toute une plateforme Multi... Cliquez pour télécharger PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO Academy System (17.2.1.0)ACADEMY SYSTEM (17.2.1.0)Logiciel de gestion des établissements.
- élèves/étudiants (inscription, dossier, absence...)
-... Cliquez pour télécharger Academy System Easy-Planning (1.0.0.1)EASY-PLANNING (1.0.0.1)Basé sur les mêmes principes que MyPlanning, Easy-Planning permet de créer des plannings sous la ... Cliquez pour télécharger Easy-Planning COLLECTOR PLUS (3.00B)COLLECTOR PLUS (3.00B)COLLECTOR PLUS version 3.00B est un logiciel utilisant une base de données alimentée par :
- L... Cliquez pour télécharger COLLECTOR PLUS LettresFaciles 2011 (8.0.0.1)LETTRESFACILES 2011 (8.0.0.1)LettresFaciles est un logiciel facilitant la création et la rédaction de lettres types.
Son inte... Cliquez pour télécharger LettresFaciles 2011
|