Sub test()
Dim Rg As Range, Sh As Worksheet, ModeCalcul As Long
Dim Arr(), A As Integer, Elt As Variant, Adr As String
'-------------Variables à définir----------------
Set Sh = Worksheets(ActiveSheet.Name) 'Nom feuille à adapter
'------------------------------------------------
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Reset_Mise_En_page Sh
Arr = Array("=MOD(row(A2),3)=0", "=MOD(row(A1),3)=0")
For Each Elt In Arr
With Sh
.Range("A2600") = 1
Set Rg = Range("A1:F2500")
.Range("H1") = ""
.Range("H2").Formula = Elt
End With
With Rg
.AdvancedFilter xlFilterInPlace, Sh.Range("H1:H2")
If A = 0 Then
With .Range("_FilterDataBase").SpecialCells(xlCellTypeVisible)
With .Font
.Name = "EanT30Rfz"
.Size = 36
End With
End With
A = A + 1
ElseIf A = 1 Then
With .Font
.Name = "Comic Sans MS"
.Size = 18
.Bold = True
End With
A = A + 1
End If
End With
Sh.ShowAllData
DoEvents
Next
For A = 16 To Rg.Rows.Count Step 15
Sh.HPageBreaks.Add before:=Sh.Rows(A)
Next
With Sh
.DisplayPageBreaks = True
.Range("A2600") = ""
Adr = .UsedRange.Address
.Range("H2") = ""
With .Shapes("Bouton 1")
.Left = Sh.Range("C2").Left
.Top = Sh.Range("C2").Top
.Width = Sh.Range("C2:F2").Width
.Height = Sh.Range("C2:C3").Height
End With
End With
Application.Calculation = ModeCalcul
Application.ScreenUpdating = True
End Sub
'------------------------------------------------
Sub Reset_Mise_En_page(Sh As Worksheet)
Sh.ResetAllPageBreaks
Sh.UsedRange.Style = "Normal"
End Sub