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
| Option Explicit
Private Const N As Byte = 4 'max élèves par ligne
Private Const Sep As String = "; " 'Séparateur entre élèves de même ligne
Sub CopierLesNoms()
Dim oWs As Variant
Application.ScreenUpdating = False
Effacer
For Each oWs In Array(Feuil8, Feuil1) 'ICI METTRE LES CODENAME DES FEUILLES SOURCES CONCERNEES
CopiesNomsomsParNiveau oWs
Next oWs
MsgBox "Transcription terminée..."
End Sub
Private Sub CopiesNomsomsParNiveau(ByVal Ws As Worksheet)
Dim Jour As String, Creneau As String, Eleve As String, Classe As String, Semaine As String
Dim Col As Integer, k As Integer
Dim Lastlig As Long, i As Long
Dim Doub As Boolean
Dim c As Range
With Ws
For k = 1 To 26 Step 5
Lastlig = .Cells(.Rows.Count, k + 1).End(xlUp).Row
If Lastlig > 2 Then
Classe = .Cells(1, k).Text
For i = 3 To Lastlig
If .Cells(i, k).Value <> "" Then Eleve = .Cells(i, k).Value
Jour = .Cells(i, k + 1).Value
Creneau = .Cells(i, k + 2).Value
Semaine = .Cells(i, k + 3)
If FeuilleExiste(Jour) Then
With Worksheets(Jour)
Set c = .Columns(1).Find(Creneau, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Doub = Semaine = ""
Col = IIf(Semaine = "B", 8, 4)
EcrireEleve .Cells(c.Row, Col), Eleve, Classe
If Doub Then EcrireEleve .Cells(c.Row, 8), Eleve, Classe
End If
End With
End If
Next i
End If
Next k
End With
End Sub
Private Sub EcrireEleve(ByVal Rng As Range, ByVal Elv As String, ByVal Cla As String)
Dim NewLig As Boolean
With Rng
If .Value = "" Then
.Resize(, 2).Value = Array(Elv, "'" & Cla)
Else
NewLig = InStr(.Offset(, 1).Value, Cla) = 0 Or GoNewLine(.Value)
.Value = .Value & IIf(NewLig, Chr(10), Sep) & Elv
If NewLig Then .Offset(, 1).Value = .Offset(, 1).Value & Chr(10) & Cla
End If
End With
End Sub
Private Function GoNewLine(ByVal S As String) As Boolean
Dim i As Integer
Dim Tb
Tb = Split(S, Chr(10))
S = Tb(UBound(Tb))
GoNewLine = Len(S) - Len(Replace(S, Sep, "")) >= (N - 1) * Len(Sep)
End Function
Private Sub Effacer()
Dim oWs As Variant
For Each oWs In Array(Feuil2, Feuil4, Feuil5, Feuil6, Feuil7) 'ICI METTRE LES CODENAME des feuilles lundi, mardi,....vendredi
oWs.Cells(5, 4).Resize(29, 2).ClearContents
oWs.Cells(5, 8).Resize(29, 2).ClearContents
Next oWs
End Sub
Private Function FeuilleExiste(ByVal Tmp As String) As Boolean
On Error Resume Next
FeuilleExiste = Worksheets(Tmp).Index
End Function |
