Bonjour,
J'ai la macro ci-dessous que j'utilisais sur des machines équipés de Excel 2003 pour recalculer une nomenclature.
Lorsque je lances cette macro sur un Excel 2007 ou 2010 les colonnes où le montant étaient recalculé ne se fait plus. J'y ai passé des heures mais je ne trouve pas.
Avez-vous une idée ? Merci d'avance

Je peux vous fournir un exemple de fichier Excel également mais sur quel lien le stocker ?


Code : Sélectionner tout - Visualiser dans une fenêtre à part
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