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
| Sub InserST()
Dim pb As Object
Dim C As Range
Dim i As Byte, j As Byte, k As Byte
Dim ReportSTe As Double, ReportSTf As Doubl
Dim h As Integer
'Dim Last As Integer
ActiveWindow.View = xlPageBreakPreview
'***********************************Partie 1 : Suppression des sous-totaux*******************************************************************************
With ActiveSheet.Range("D16:D" & Range("D" & Application.Rows.Count).End(xlUp).Row)
Do
Set C = .Find("Total")
If Not C Is Nothing Then
Cells(C.Row, "D").EntireRow.Delete
End If
Loop While Not C Is Nothing
End With
'***********************************Partie 2 : Définition auto de la zone d'impression*******************************************************************
ActiveSheet.PageSetup.PrintArea = "$D$1:" & Range("I" & Application.Rows.Count).End(xlUp).Address
'***********************************Partie 3 : gestion des sauts de page*********************************************************************************
i = 0
j = 0
For Each pb In ActiveSheet.HPageBreaks
i = i + 1 '***incrémente le n°de saut de page général(Permet de gérer le cas de sauts de pages externes à la zone d'impression)
If pb.Extent = xlPageBreakPartial Then
j = j + 1 '***incrémente le n°de saut de page de la zone d'impression
Set Cpb = ActiveSheet.HPageBreaks(i).Location
If Cpb.Value <> "Report Sous-Total" Then
Range(Cells(Cpb.Row - 1, Cpb.Column), Cells(Cpb.Row, Cpb.Column)).EntireRow.Insert (xlShiftDown)
Cells(Cpb.Row - 3, Cpb.Column) = "Sous-Total"
If j = 1 Then
Cells(Cpb.Row - 3, "I").Formula = "=SUM(I16:I" & Cpb.Row - 4 & ")"
With Range(Cells(Cpb.Row - 3, "D"), Cells(Cpb.Row - 2, "I"))
.Interior.ColorIndex = 40
.Font.Bold = True
End With
Else
k = WorksheetFunction.Max(9, ActiveSheet.HPageBreaks(i - 1).Location.Row)
Cells(Cpb.Row - 3, "I").Formula = "=SUM(I" & k & ":I" & Cpb.Row - 4 & ")"
With Range(Cells(Cpb.Row - 3, "D"), Cells(Cpb.Row - 2, "I"))
.Interior.ColorIndex = 40
.Font.Bold = True
End With
End If
Cells(Cpb.Row - 2, Cpb.Column) = "Report Sous-Total"
Cells(Cpb.Row - 2, "I") = Cells(Cpb.Row - 3, "I")
End If
End If
Next
'******************************************Partie 4 : Affichage du total bas de page *****************************************************************************************
Last = Range("D" & Application.Rows.Count).End(xlUp).Row
If Cells(Last, "D") <> "Total Général" Then
Cells(Last, "D").EntireRow.Insert (xlShiftDown) '**Permet d'étendre la zone d'impression
Range(Cells(Last + 1, "D"), Cells(Last + 1, "I")).Copy (Cells(Last, "D"))
Cells(Last + 1, "D").EntireRow.ClearContents
Cells(Last + 1, "D") = "Total Général"
ActiveSheet.Cells(Last + 1, "I") = "=SUM(I" & WorksheetFunction.Max(9, Cpb.Row - 2) & ":I" & Last & ")+I5"
'Cells(Last + 1, "F") = "=SUM(F" & WorksheetFunction.Max(9, Cpb.Row - 2) & ":F" & Last & ")+F5"
With Range(Cells(Last + 1, "D"), Cells(Last + 1, "I"))
.Interior.ColorIndex = 45
.Font.Bold = True
End With
End If
ActiveWindow.View = xlNormalView
'miseEnPageAvantImpression
'Ajuster
Application.Dialogs(xlDialogPrint).Show
End Sub |
Partager