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
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
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub 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
Voulez-vous que je vous donne un exemple de de fichier ?
Le pas à pas ne me donne rien.
Sub prix_revient_nomenclature()qui ne fonctionne pas.
Dim appWD As Word.Application