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
|
Sub Relevé()
Dim cel As Range, i As Integer, derLigne As Integer, premLigne As Integer
Dim ligneEcri As Integer, Salarie As String, Remplaçant As String, colEcri As Integer
'je nettoie le contenu de la feuille "DIMANCHE"
Sheets("DIMANCHE").Range("B5:G78").ClearContents
Sheets("MATRICE2014").Activate
'Lecture du tableau de la feuille Matrice 2014
premLigne = 11: ligneEcri = 5
derLigne = Range("B" & Rows.Count).End(xlUp).Row
colEcri = 1
'Pour empêcher le clignotement pendant le fonctionnement
Application.ScreenUpdating = False
'Boucle pour parcourir une ligne sur deux en lecture
Do Until premLigne >= derLigne
For Each cel In Range(Cells(premLigne, 2), Cells(premLigne, 33))
'Pour vérifier si on est un dimanche
If Cells(7, cel.Column) = "" Then GoTo Suite
If Weekday(Cells(7, cel.Column)) = 1 Then
'Colonne pour écrire
colEcri = colEcri + 1
'lecture des données à écrire
Salarie = Cells(cel.Row, 2)
Remplaçant = cel.Offset(1, 0)
date_travail = ActiveCell '*****AJOUT
DateJour = CDate(Cells(7, cel.Column))
'Voir si travail il y a
If cel <> "R" Then '*****MODIF And Cells(cel.Row, 2) <> "REMPLACANT" Then
'On ouvre la feuille pour écrire
Sheets("DIMANCHE").Activate
If Cells(4, colEcri) = DateJour Then
Cells(ligneEcri, colEcri) = Salarie
Cells(ligneEcri + 1, colEcri) = Remplaçant
Cells(ligneEcri + 2, colEcri) = date_travail '******AJOUT
End If
End If
End If
Suite:
'On retourne dans la feuille pour lire les données suivantes
Sheets("MATRICE2014").Activate
Next
'Incrémentation des lignes de lecture et d'écriture
ligneEcri = ligneEcri + 3 '*****MODIF
premLigne = premLigne + 2
'Retour à la première colonne pour écrire la nouvelle ligne suivante
colEcri = 1
Loop
Application.ScreenUpdating = True
Sheets("DIMANCHE").Activate
End Sub |
