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
105
106
107
| Option Explicit
Private Function Normalize(Tb As Variant) As Integer()
Dim Tmp() As Integer
Dim i As Integer, Hi As Integer
Dim Lo As Byte
Lo = LBound(Tb): Hi = UBound(Tb)
ReDim Tmp(Lo To Hi)
Tmp(Lo) = 0
For i = Lo + 1 To Hi
If Tb(i) > Tb(i - 1) Then
Tmp(i) = 1
ElseIf Tb(i) < Tb(i - 1) Then
Tmp(i) = -1
End If
Next i
Normalize = Tmp
Erase Tmp
End Function
Private Function Reorganize(Tblo As Variant, Ind As Byte) As Integer()
Dim tmpTblo() As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Hi As Integer
Dim Lo As Byte
Lo = LBound(Tblo): Hi = UBound(Tblo)
ReDim tmpTblo(Lo To Hi)
For i = Lo To Hi
If Tblo(i) > 0 Then
j = j + 1
ElseIf Tblo(i) < 0 Then
k = k - 1
End If
If j = Ind Then
tmpTblo(i) = Ind
j = 0
ElseIf k = -Ind Then
tmpTblo(i) = -Ind
k = 0
End If
Next i
Reorganize = tmpTblo
Erase tmpTblo
End Function
Public Function ArrayZero(Tbl As Variant) As Boolean
ArrayZero = (Application.Max(Tbl) = 0) And (Application.Min(Tbl) = 0)
End Function
Sub APPLIQUER()
Dim Sh As Worksheet
Dim Tbl() As Integer, normTbl() As Integer
Dim LastLig As Long, i As Long
Dim j As Byte, k As Byte, Deb As Byte
Dim Plage As Range, c As Range
Application.ScreenUpdating = False
With Sheets("Data")
LastLig = .Cells(.Rows.Count, "FB").End(xlUp).Row 'Dernière ligne de donnée (Colonne BF comme référence)
For i = 20 To LastLig
Set Plage = .Range("AL" & i & ":FB" & i) 'On cherche pour chaque ligne i la colonne de debut des données Deb
Set c = Plage.Find("*")
If Not c Is Nothing Then 'Si la ligne n'est pas vide
Deb = c.Column
Set c = Nothing
ReDim Tbl(1 To 159 - Deb) 'On met dans tbl les données de la ligne i (de Deb jusqu'à la colonne BF)
For k = 1 To 159 - Deb
Tbl(k) = .Cells(i, k + Deb - 1).Value
Next k
ReDim normTbl(1 To 159 - Deb)
normTbl = Normalize(Tbl) 'On normalise Tbl
'-----------------------------------------------Pour chaque ligne i, on boucle sur tous les cas de 1 à 9
For j = 1 To 9
If j = 1 Then
Tbl = normTbl 'Pour la cas1 le tableau final est celui normalisé
Else
Tbl = Reorganize(normTbl, j) 'Pour les autres cas j on réorganise le tableau en fonction de j
End If
If ArrayZero(Tbl) Then Exit For 'Si le tableau résultat ne comporte que des 0, on arrête et on passe à la ligne i suivante
On Error Resume Next 'à partir d'ici, création des feuilles CAS_j si elle n'exisyent pas et report des tableaux réorganisés pour chaque ligne
Set Sh = Sheets("CAS_" & j)
On Error GoTo 0
If Sh Is Nothing Then
Set Sh = Sheets.Add(After:=Worksheets(Worksheets.Count))
Sh.Name = "CAS_" & j
Sh.Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=0"
Sh.Cells.FormatConditions(1).Interior.ColorIndex = 53
End If
Sh.Range(Sh.Cells(i, Deb), Sh.Cells(i, 158)).Value = Tbl
Sh.Range("A1:BF1").ColumnWidth = 1
Sh.UsedRange.Columns.AutoFit
Set Sh = Nothing
Erase Tbl
Next j
'-----------------------------------------------
End If
Erase normTbl
Set Plage = Nothing
DoEvents
Application.StatusBar = String(80, " ") & "Traitement en cours... " & Application.RoundUp(100 * (i - 20) / (LastLig - 20), 0) & "%"
Next i
.Activate
End With
Application.StatusBar = ""
Application.ScreenUpdating = True
MsgBox "Traitement terminé..."
End Sub |
Macro à Terminer
Répondre avec citation
Partager