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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
| Option Explicit
Option Base 1
Const codeb = 19
Const lideb = 20
Const lifin = 619
Const cofin = 158
Const nbco = cofin - codeb + 1
Const nbli = lifin - lideb + 1
Const nbcas = 9
Const FeuilleSource = "Data"
Const coldeb = "S"
Const colfin = "FB"
Const plage = coldeb & lideb & ":" & colfin & lifin
Const colonnes = "A:FB"
Const NomGeneriqueFeuille = "Cas "
Sub RemplirUneFeuille(nucas As Long)
Dim li As Long, co As Long, lires As Long, nbchange As Long
Dim Tligne
Dim Tchange
Dim ligne As String
Dim vcour As Variant, vprec As Variant
Dim FeuilleRes As String
FeuilleRes = NomGeneriqueFeuille & nucas
lires = lideb 'liresdeb
' on met la ligne li dans Tligne, on initialise Tchange
For li = lideb To lifin
ligne = coldeb & li & ":" & colfin & li
Tligne = Sheets(FeuilleSource).Range(ligne).Value
Tchange = Tligne
' MsgBox (Tligne(1, 34))
For co = 1 To nbco
If Tligne(1, co) = "" Then
Tchange(1, co) = ""
Else
Tchange(1, co) = 0
End If
Next co
' on traite les changements ligne li
nbchange = 0
For co = 1 To nbco - 1
vprec = Tligne(1, co)
vcour = Tligne(1, co + 1)
If (vcour = "" Or vprec = "") Then
' rien
Else
If vcour <> vprec Then
nbchange = nbchange + 1
If nbchange = nucas Then
Tchange(1, co + 1) = nbchange
nbchange = 0
End If
End If
End If
Next co
' affichage de Tchange en ligne lires de FeuilleRes
Sheets(FeuilleRes).Range(ligne).Value = Tchange
lires = lires + 1
Next li
End Sub
Sub Toutes()
Dim numcas As Long, nbfeuilles As Long
Dim NomFeuille As String, Feuille As Variant
' creation des nbcas feuilles
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Feuille In Sheets
If Feuille.Name <> "Data" Then Feuille.Delete
Next
Application.DisplayAlerts = True
For numcas = 1 To nbcas
NomFeuille = NomGeneriqueFeuille & numcas
nbfeuilles = Sheets.Count
' ajouter une feuille
Sheets.Add
ActiveWindow.Zoom = 75
ActiveSheet.Name = NomFeuille
ActiveSheet.Columns(colonnes).HorizontalAlignment = xlCenter
With ActiveSheet.Range(plage)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual, Formula1:="1"
.FormatConditions(1).Interior.ColorIndex = 40
End With
Sheets(NomFeuille).Move after:=Sheets(Sheets.Count)
Next numcas
Application.ScreenUpdating = True
' remplir les nbcas feuilles
For numcas = 1 To nbcas
RemplirUneFeuille (numcas)
Next numcas
End Sub |
Macro à Terminer
Répondre avec citation
Partager