Mettre jour spécifique dans feuille

**stéphane35200** · 14/12/2014, 13h14

Bonjour,
voila je cherche le moyen via MSCAL.Calendar. excel 2007 'davoir la date en cellule B1 sa c'est ok
en dessous en b2 il me met la date que j'ai cliquer (fonctionne)
mais car y'en a toujours un en c2j'amerais avoir la suite du calendrier sur un jour spécifique exemple:
b1 = 01/12/2014 soit un lundi (jour qui m'intéresse)
reporté en b2
donc b2 me met 01/12/2014 c2 me met 02/12/2014 etc etc
ce que j'aimerais c'est avoir lundi en b2 mercredi en c2 vendredi en d2 samedi en e2 lundi en f2 mardi en g2 et ce jusqu’à la fin du mois
mais lorsque je change de mois via calendar janvier 2015 c'est jeudi qui s'affiche et je ne veut pas des dimanche, mardi, jeudi ces jours la ne m’intéresse pas
je joint le fichier pour mieux comprendre si vous avez une idée je suis preneur presence - Copie.xlsm

Invité · 14/12/2014, 15h30

Bonjour,

Dans le fichier joint, un exemple à adapter à votre cas.

En tapant n'importe quel jour du mois à étudier, la macro calcule et met en forme les dates des jours souhaités.

Un module standard contient cette macro

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
Option Explicit
 
Public ShPresentation As Worksheet
 
Sub MettreAJourLeTableau(ByVal DateEtudiee As Date, ByVal CelluleDebut As Range)
 
Dim DateDebut As Date
Dim DateATester As Date
Dim DateFin As Date
Dim JourDuMoisEncours As Integer
 
    DateDebut = CDate("01/" & Month(DateEtudiee) & "/" & Year(DateEtudiee)) ' Quel que soit le jour saisi, le premier jour est le premier du mois
    DateFin = WorksheetFunction.EDate(DateDebut, 1) - 1 ' On prend le premier jour du mois suivant - 1
 
    With Rows(CelluleDebut.Row).Cells
        .Interior.Color = xlNone
        .HorizontalAlignment = xlCenter
        .RowHeight = 25
    End With
 
    Range(CelluleDebut, CelluleDebut.Offset(0, 31)).Clear
 
    JourDuMoisEncours = 1
    For DateATester = DateDebut To DateFin
 
        Select Case WorksheetFunction.Weekday(DateATester, 2)
            Case 1, 3, 5 ' Lundi, mercredi, vendredi
                With CelluleDebut.Offset(0, JourDuMoisEncours)
                    .Value = DateATester
                    .NumberFormat = "[$-40C]ddd d mmm "
                    .ColumnWidth = 12
                End With
 
                JourDuMoisEncours = JourDuMoisEncours + 1
 
            Case 6 ' Samedi
                With CelluleDebut.Offset(0, JourDuMoisEncours)
                    .Value = DateATester
                    .Interior.ColorIndex = 6
                    .NumberFormat = "[$-40C]ddd dd mmm "
                    .ColumnWidth = 12
                End With
                JourDuMoisEncours = JourDuMoisEncours + 1
 
        End Select
 
    Next DateATester
 
 
End Sub

Le module de l'onglet "Présentation" contient le code suivant :

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
Option Explicit
 
 
Private Sub Worksheet_SelectionChange(ByVal CelluleMoisEtudie As Range)
 
   If CelluleMoisEtudie.Count > 1 Then Exit Sub
 
   On Error Resume Next
   If Not Application.Intersect(CelluleMoisEtudie, Range("PremierJourDuMoisEtudie")) Is Nothing Then
 
            Set ShPresentation = Sheets("Présentation")
            With ShPresentation
                MettreAJourLeTableau CDate(.Range("PremierJourDuMoisEtudie")), .Range("PremierJourDuMoisEtudie").Offset(1, 0)
            End With
            Set ShPresentation = Nothing
 
   End If
 
End Sub

Cordialement.

**stéphane35200** · 14/12/2014, 21h15

merci Eric
marche bien ton code et comme je connais peu le vba je voudrais inclure mes case a cocher dedans
j'ai erreur sur la ligne 2 et le mot target est en bleu est-ce possible de raccorder ces deux code vba de façon a ce que j'ai mes case a cocher en cellule $c$3:$t$60

et j'ai vu aussi qu'il faut rentré la date en cellule B1 n'y a t'il pas possibilité de le faire avec calendar ?

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
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal CelluleMoisEtudie As Range)




   If CelluleMoisEtudie.Count > 1 Then Exit Sub
   
   On Error Resume Next
   If Not Application.Intersect(CelluleMoisEtudie, Range("PremierJourDuMoisEtudie")) Is Nothing Then

            Set ShPresentation = Sheets("Présence")
            With ShPresentation
                MettreAJourLeTableau CDate(.Range("PremierJourDuMoisEtudie")), .Range("PremierJourDuMoisEtudie").Offset(1, 0)
            End With
            Set ShPresentation = Nothing

   


If Not Application.Intersect(Target, Range("=$c$3:$t$60")) Is Nothing Then


'définit si la cellule pointe sur une zone à cocher ou pas - si non, on sort de la routine
'zone des cases à cocher (Plage_Cochée) nom défini dans la feuille
'target est la cellule sous le pointeur lors du double clic
If Target = "o" Then
  Target = "þ"
Else
    If Target = "þ" Then
   ' Target = "o"
   ' End If
   ' End If
    End If

    
End Sub

Invité · 15/12/2014, 06h42

Bonjour,

Copier le code ci-dessous dans un module standard de votre fichier Présence.

Attention : Dans votre fichier la feuille "Pointage " contient un caractère vide à la fin. Il faut le supprimer pour que la macro de mise à jour fonctionne. Un message d'avertissement vous demande de confirmer la réinitialisation du tableau avant de "tout nettoyer".

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
Option Explicit
 
Public CelluleCalendar As Range
Public AireDeSaisie As Range
 
Public Configuration As Integer
Public Reponse As Integer
 
 
Sub MettreAJourLeTableau(ByVal DateEtudiee As Date, ByVal CelluleDebut As Range, ByVal AireDeCollecte As Range)
 
Dim DateDebut As Date
Dim DateATester As Date
Dim DateFin As Date
Dim JourDuMoisEncours As Integer
 
    ' Mise à jour de la ligne des titres
    '-----------------------------------
    DateDebut = CDate("01/" & Month(DateEtudiee) & "/" & Year(DateEtudiee)) ' Quel que soit le jour saisi, le premier jour est le premier du mois
    DateFin = WorksheetFunction.EDate(DateDebut, 1) - 1 ' On prend le premier jour du mois suivant
 
    With Rows(CelluleDebut.Row).Cells
        .Interior.Color = xlNone
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 25
    End With
 
    Range(CelluleDebut.Offset(0, 1), CelluleDebut.Offset(0, 31)).Clear
 
    JourDuMoisEncours = 1
    For DateATester = DateDebut To DateFin
 
        Select Case WorksheetFunction.Weekday(DateATester, 2)
            Case 1, 3, 5 ' Lundi, mercredi, vendredi
                With CelluleDebut.Offset(0, JourDuMoisEncours)
                    .Value = DateATester
                    .NumberFormat = "[$-40C]ddd d mmm "
                    .ColumnWidth = 12
                End With
 
                JourDuMoisEncours = JourDuMoisEncours + 1
 
            Case 6 ' Samedi
                With CelluleDebut.Offset(0, JourDuMoisEncours)
                    .Value = DateATester
                    .Interior.ColorIndex = 6
                    .NumberFormat = "[$-40C]ddd dd mmm "
                    .ColumnWidth = 12
                End With
                JourDuMoisEncours = JourDuMoisEncours + 1
 
        End Select
 
    Next DateATester
 
    ' Mise à jour de la zone de collecte du tableau
    '----------------------------------------------
    With AireDeCollecte
        .Value = "o"
        .VerticalAlignment = xlCenter
    End With
 
End Sub
 
Sub IncorporerUnMessage(Titre, Message)
 
    Configuration = vbCritical + vbYesNo + vbQuestion
    Reponse = MsgBox(Message, Configuration, Titre)
 
End Sub

Dans le module de l'onglet "Pointage", remplacer dans Private Sub Calendar1_Click() le code existant par celui-ci :

Je ne dispose pas de la dll Calendar sur mon poste. Normalement ce code devrait fonctionner correctement car testé avec une procédure classique.

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
 
Private Sub Calendar1_Click()
 
    With Sheets("pointage")
 
         Set CelluleCalendar = .Range("B1")
         Set AireDeSaisie = .Range("C3:T59")
 
         IncorporerUnMessage "Réinitialisation du tableau", "Après validation le tableau sera réinitialisé, continuer ?"
 
         If Reponse = 6 Then
            CelluleCalendar.Value = Calendar1.Value
            MettreAJourLeTableau CDate(CelluleCalendar), CelluleCalendar.Offset(1, 0), AireDeSaisie
         End If
 
         Set CelluleCalendar = Nothing
         Set AireDeSaisie = Nothing
 
    End With
 
End Sub

Cordialement.

**stéphane35200** · 17/12/2014, 01h14

Merci pour le coup de main

Mettre jour spécifique dans feuille [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager