Discussion :

[sebfch]

Bonjour,

j'aimerais une macro qui me donne le numéro des jours(lundi au vendredi) suivant le numéro des semaines et l'année.

Par exemple :
semaine 1:
lundi 2 au vendredi 6 janvier 2015
semaine 2 :
lundi 9 au vendredi 13 janvier 2015

Est ce possible ?

[Marc-L]

Bonjour !

Oui tu peux le faire ! (Voir les règles du forum …)

Avec la fonction VBA Weekday tu lis le jour de la semaine du premier jour de l'année

puis tu te décales sur le lundi suivant et enfin avec une boucle For … Next ou encore Do … Loop …

Tout est documenté dans l'aide VBA interne sans compter les tutoriels de ce forum !

______________________________________________________________________________________________________
Je suis Paris, Charlie, Bruxelles, …

[sebfch]

J'aimerais bien un exemple parce que je comprends rien à la fonction
du genre m'afficher pour l'année 2016 toutes les semaines avec les jours correspondant (sans les samedis et dimanches)

[kiki29]

Salut, un calendrier sans Samedi, Dimanche et jours fériés, avec une plage nommée Année, qui après qqs modifs/élagages te donnera la vue de droite.

A lire également.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Option Explicit
 
Dim JFeries(10) As Long
 
Private Function JoursFeries(An As Long)
Dim Nb As Long, Epacte As Long
Dim PLune As Date, LPaques As Date
Dim i As Long, j As Long, k As Long, tmp As Long
 
    '   Calcul du Lundi de Pâques
    Nb = (An Mod 19) + 1
    '   Différence entre calendrier solaire et lunaire
    Epacte = (11 * Nb - (3 + Int(2 + Int(An / 100)) * 3 / 7)) Mod 30
    PLune = DateSerial(An, 4, 19) - ((Epacte + 6) Mod 30)
    If Epacte = 24 Then PLune = PLune - 1
    If Epacte = 25 And (An >= 1900 And An < 2200) Then PLune = PLune - 1
 
    LPaques = PLune - Weekday(PLune) + vbMonday + 7
 
    Erase JFeries
    JFeries(0) = DateSerial(An, 1, 1)
    JFeries(1) = LPaques
    JFeries(2) = LPaques + 38
    JFeries(3) = LPaques + 49
    JFeries(4) = DateSerial(An, 5, 1)
    JFeries(5) = DateSerial(An, 5, 8)
    JFeries(6) = DateSerial(An, 7, 14)
    JFeries(7) = DateSerial(An, 8, 15)
    JFeries(8) = DateSerial(An, 11, 1)
    JFeries(9) = DateSerial(An, 11, 11)
    JFeries(10) = DateSerial(An, 12, 25)
 
    For i = 1 To UBound(JFeries)
        j = i
        For k = j + 1 To UBound(JFeries)
            If JFeries(k) <= JFeries(j) Then j = k
        Next k
        If i <> j Then
            tmp = JFeries(j)
            JFeries(j) = JFeries(i)
            JFeries(i) = tmp
        End If
    Next i
End Function
 
Sub Calendrier_02()
Dim DateDepart As Long, DateFin As Long, i As Long, j As Long
Dim Dat() As Long
Dim c As Range, LastRow As Long
 
    Feuil1.Columns(1).Clear
    Application.ScreenUpdating = False
    JoursFeries Feuil1.Range("Annee")
 
    DateDepart = CDate("1/1/" & Feuil1.Range("Annee"))
    DateFin = CDate("31/12/" & Feuil1.Range("Annee"))
 
    ReDim Dat(1 To DateFin - DateDepart + 1, 1 To 1)
    For i = CLng(DateDepart) To CLng(DateFin)
        Dat(i - DateDepart + 1, 1) = i
    Next i
 
    Set c = Feuil1.Range("A1")
    With c.Resize(DateFin - DateDepart + 1, 1)
        .NumberFormatLocal = "jjj jj mmm aa"
        .Font.Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Value = Dat
    End With
    Set c = Nothing
 
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
 
    For i = LastRow To 1 Step -1
        For j = 0 To 10
            If Feuil1.Cells(i, 1) = JFeries(j) Or _
               Weekday(Feuil1.Cells(i, 1)) = vbSaturday Or _
               Weekday(Feuil1.Cells(i, 1)) = vbSunday Then
                Feuil1.Range("A" & i).Delete Shift:=xlUp
                Exit For
            End If
        Next j
    Next i
 
    Feuil1.Range("C2").Select
    Application.ScreenUpdating = True
 
End Sub

[sebfch]

Super merci pour ton temps