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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
| Option Explicit
Public strOldFile As String
Public strNewFile As String
Public intCol As Integer
Public Sub Traitement()
Dim wbkOldFile As Workbook
Dim wbkNewFile As Workbook
Dim wbkTraitement As Workbook
Dim shtTraitement As Worksheet
Application.ScreenUpdating = False
'Ouverture des classeurs
Set wbkTraitement = ActiveWorkbook
Set wbkOldFile = Workbooks.Open(strOldFile)
Set wbkNewFile = Workbooks.Open(strNewFile)
'Création de l'onglet
wbkTraitement.Activate
On Error GoTo Erreur_sht
Set shtTraitement = Worksheets("Traitement")
On Error GoTo 0
With shtTraitement
.Cells.Clear
.Select
End With
'Copie des données
wbkNewFile.ActiveSheet.UsedRange.Copy shtTraitement.Range("A1")
intCol = ActiveSheet.UsedRange.Columns.Count + 1
wbkNewFile.Close False
'Mise en forme des données
shtTraitement.UsedRange.Columns.AutoFit
shtTraitement.UsedRange.Rows.AutoFit
'Gestion des ajouts
Call Ajouts(wbkOldFile)
'Gestion des suppressions
Call Suppressions(wbkOldFile)
'Gestion des modifications
Call Modifications(wbkOldFile)
'Mise en forme conditionnelle
Call MiseEnFormeConditionnelle
wbkOldFile.Close False
Application.Goto Range("A1"), True
Exit Sub
'Cas ou la feuille 'Traitement' n'existe pas
Erreur_sht:
Set shtTraitement = Worksheets.Add(After:=Worksheets(Worksheets.Count))
shtTraitement.Name = "Traitement"
Resume Next
End Sub
'Gestion des Ajouts
Private Sub Ajouts(wbkOld As Workbook)
Dim rngC As Range
For Each rngC In ActiveSheet.UsedRange.Rows
If rngC.Row <> 1 Then
If RechercheAjouts(Cells(rngC.Row, 1), wbkOld.ActiveSheet.UsedRange) = False Then
Cells(rngC.Row, intCol) = "A"
End If
End If
Next rngC
End Sub
'Gestion des Suppressions
Private Sub Suppressions(wbkOld As Workbook)
Dim rngC As Range
Dim intRowOld As Integer, intRowNew As Integer
With wbkOld.ActiveSheet
For Each rngC In .UsedRange.Rows
If rngC.Row <> 1 Then
If RechercheAjouts(.Cells(rngC.Row, 1), ActiveSheet.UsedRange) = False Then
'Recherche vers le haut
intRowOld = rngC.Row
intRowNew = RechercheSuppressions(.Cells(intRowOld - 1, 1), ActiveSheet.UsedRange)
While intRowNew = -1
intRowOld = intRowOld - 1
intRowNew = RechercheSuppressions(.Cells(intRowOld, 1), ActiveSheet.UsedRange)
If intRowOld = 1 Then intRowNew = 1
Wend
'Copie des données
Rows(intRowNew + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range(.Cells(rngC.Row, 1), .Cells(rngC.Row, intCol)).Copy ActiveSheet.Range(Cells(intRowNew + 1, 1), Cells(intRowNew + 1, intCol))
Cells(intRowNew + 1, intCol) = "S"
End If
End If
Next rngC
End With
End Sub
'Gestion des Modifications
Private Sub Modifications(wbkOld As Workbook)
Dim rngC As Range
Dim intRowOld As Integer, intColOld As Integer
With wbkOld.ActiveSheet
For Each rngC In ActiveSheet.UsedRange.Rows
If rngC.Row <> 1 Then
If Not Cells(rngC.Row, intCol) <> "" Then
intRowOld = RechercheSuppressions(Cells(rngC.Row, 1), .UsedRange)
For intColOld = 1 To intCol - 1
If Cells(rngC.Row, intColOld) <> .Cells(intRowOld, intColOld) Then
Cells(rngC.Row, intColOld).Interior.ColorIndex = 45
Cells(rngC.Row, intCol) = "M"
End If
Next intColOld
End If
End If
Next rngC
End With
End Sub
'Mise en forme conditionelle
Public Sub MiseEnFormeConditionnelle()
Dim rngRange As Range
Set rngRange = ActiveSheet.UsedRange
rngRange.FormatConditions.Delete
[A1].Select
With rngRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$Q1=""A""")
.Interior.ColorIndex = 10
End With
With rngRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$Q1=""S""")
.Interior.ColorIndex = 3
End With
End Sub |
