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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
| Sub suppr_lignes_vides()
'11/01/2009
derniereligne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereligne To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
End Sub
Sub groupe_niveaux_nomenclature()
'11/01/2009
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
derniereligne = ActiveSheet.UsedRange.Rows.Count
'Application.ScreenUpdating = False
If Cells(8, 1) <> 1 Then '9 avant PSB
MsgBox "erreur niveau 1"
Else
For niveau = 1 To 3
index1 = 0
For r = 9 To derniereligne + 1 '10 avant PSB
If Cells(r, 1) > niveau Then
If index1 = 0 Then index1 = r
ElseIf index1 <> 0 Then
index2 = r - 1
Rows(CStr(index1 & ":" & index2)).Group
index1 = 0
End If
Next r
Next niveau
End If
End Sub
Sub dec_gauche_1er_cellule_vides()
'11/01/2009
derniereligne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereligne To 7 Step -1 '8 avant PSB
If IsEmpty(Cells(r, 1)) Then Cells(r, 1).Delete Shift:=xlToLeft
Next r
End Sub
Sub mise_en_forme_nomenclature()
'25/05/2009
derniereligne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
'decale la première cellule vide
For r = derniereligne To 7 Step -1 '8 avant PSB
If IsEmpty(Cells(r, 1)) Then Cells(r, 1).Delete Shift:=xlToLeft
Next r
'colorie selon les niveaux
With Columns("A:A")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="1"
.FormatConditions(1).Interior.ColorIndex = 16
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="2"
.FormatConditions(2).Interior.ColorIndex = 48
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="3"
.FormatConditions(3).Interior.ColorIndex = 15
End With
'filtre automatique
Range("A7:I7").Font.Bold = True '8 avant PSB
Range(CStr("A7:I" & derniereligne)).AutoFilter '8 avant PSB
'bordure
Range(CStr("A7:J" & derniereligne)).Select '8 avant PSB
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'largeur des colonnes
Columns("A:A").ColumnWidth = 6
Columns("B:B").ColumnWidth = 14
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").ColumnWidth = 5
Columns("E:E").ColumnWidth = 4
Columns("F:F").ColumnWidth = 5
Columns("G:G").ColumnWidth = 10
Columns("H:H").EntireColumn.AutoFit
'supprime 3 dernieres lignes
Rows(derniereligne).Delete
Rows(derniereligne - 1).Delete
Rows(derniereligne - 2).Delete
End Sub
Sub mise_en_forme_prix_de_revient()
'16/09/2009
derniereligne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = 8 To derniereligne '9 avant PSB
'colonne option à 0 et copie montant total
Cells(r, 11).Value = 1
niveau = Cells(r, 1).Value
Cells(r, 11 + niveau).FormulaR1C1 = "=RC[" & CStr(-1 - niveau) & "]*RC[" & CStr(-niveau) & "]"
Next r
End Sub
Sub prix_sous_ensemble2()
'16/0/2012
'07/05/2012 pas de calcul de sous ensemble si article coût existe
derniereligne = ActiveSheet.UsedRange.Rows.Count
For niveau = 4 To 2 Step -1
index1 = 0
For r = 9 To derniereligne + 1 '10 avant PSB
If Cells(r, 1) >= niveau Then
If index1 = 0 Then index1 = r
ElseIf index1 <> 0 Then
If IsEmpty(Cells(index1 - 1, 10)) Then
Cells(index1 - 1, 10 + niveau).FormulaR1C1 = "=R[0]C[" & CStr(1 - niveau) & "]*sum(R[1]C[1]:R[" & CStr(r - index1) & "]C[1])"
Cells(index1 - 1, 10 + niveau).Font.Bold = True
End If
index1 = 0
End If
Next r
Next niveau
With Range("L7") '8 avant PSB
.Formula = "=SUM(R8C:R" & CStr(derniereligne) & "C)" '9 avant PSB
.Font.Bold = True
.Font.ColorIndex = 3
End With
End Sub
Sub prix_revient_nomenclature()
'
' Macro enregistrée le par PLB le 14/05/12
'
Dim Fxls, Fcsv As String
Fxls = ActiveWorkbook.FullName
Fcsv = Left(Fxls, Len(Fxls) - 3) + "csv"
ActiveWorkbook.SaveAs Filename:=Fcsv, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Dim appWD As Word.Application
On Error Resume Next ' Retarde la récupération
' d'erreur.
Set appWD = GetObject(, "Word.Application")
If Err.Number <> 0 Then
' utilise CreateObject si Word n'est pas ouvert.
Set appWD = CreateObject("Word.Application")
End If
Err.Clear ' Efface l'objet Err si une erreur s'est
' produite.
With appWD
'.Visible = True
.Documents.Open (Fcsv)
.Run MacroName:="purgevirg"
.Documents.Save
.Documents.Close
.Quit
End With
Set appWD = Nothing
Workbooks.Open Filename:=Fcsv, Format:=2
Call suppr_lignes_vides
Call mise_en_forme_nomenclature
Call groupe_niveaux_nomenclature
Call mise_en_forme_prix_de_revient
Call prix_sous_ensemble2
ActiveWorkbook.SaveAs Filename:=Fxls, _
FileFormat:=xlWorkbookNormal
Kill (Fcsv)
End Sub |
Macro Excel 2003 ne fonctionne plus sous 2007/2010
Répondre avec citation
Partager