Autres Extraire des données et mise en forme de l'impression

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 3 Or Target.Column <> 2 Or Target(1) = "" Then Exit Sub
Cancel = True
With Me.PageSetup
    .PrintTitleRows = "$2:$2"
    .PrintArea = Target.CurrentRegion.Address
End With
Me.PrintPreview 'aperçu avant impression
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 3 Or Target.Column <> 2 Or Target(1) = "" Then Exit Sub
Cancel = True
Rows(2).Hidden = False 'affiche
With Me.PageSetup
    .PrintTitleRows = "$2:$3"
    .PrintArea = Target.CurrentRegion.Resize(, 6).Address
End With
Me.PrintPreview 'aperçu avant impression
Rows(2).Hidden = True 'masque
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 3 Or Target.Column <> 2 Or Target(1) = "" Then Exit Sub
Dim P As Range, c As Range, n&
Cancel = True
Set P = Target.CurrentRegion
With Sheets("Imprimante")
    .[B6] = Target
    .Range(.Rows(8), .[B:B].Find("Observation*", , xlValues)(0)).Delete 'RAZ
    .Rows(8).Resize(5 * P.Rows.Count).Insert 'insertion de lignes
    For Each c In P.Columns(2).Cells
        .Cells(8 + n, 2).Resize(4) = Application.Transpose(c.Resize(, 4))
        n = n + 5
    Next
    .PageSetup.PrintArea = "" 'zone d'impression inutile
    .PageSetup.FitToPagesWide = 1 '1 page en largeur
    .PageSetup.FitToPagesTall = 1 '1 page en hauteur
    Application.ScreenUpdating = False
    .PrintPreview 'aperçu avant impression
End With
End Sub

Private Sub CommandButton1_Click() 'Imprimer la sélection
Imprimer True
End Sub

Private Sub CommandButton2_Click() 'Imprimer tout
Imprimer False
End Sub

Sub Imprimer(choix As Boolean)
Dim r As Range, P As Range, n&, c As Range
Set r = Range("B3:B" & Rows.Count)
If Application.CountA(r) = 0 Then Exit Sub 'si le tableau est vide
If choix Then
    ActiveCell.Activate 'au cas où la sélection est un objet
    Set r = Intersect(Selection, r)
    If r Is Nothing Then Exit Sub
    Set r = IIf(r.Count = 1, r.Resize(2), r) 'au moins 2 cellules
End If
Application.ScreenUpdating = False
With Sheets("Imprimante")
    .PageSetup.PrintArea = "" 'zone d'impression inutile
    .PageSetup.FitToPagesWide = 1 '1 page en largeur
    .PageSetup.FitToPagesTall = 1 '1 page en hauteur
    For Each r In r.SpecialCells(xlCellTypeConstants)
        Set P = r.CurrentRegion
        .Cells(6, 2) = r
        .Range(.Rows(8), .Columns(2).Find("Observation*", , xlValues)(0)).Delete 'RAZ
        .Rows(8).Resize(5 * P.Rows.Count).Insert 'insertion de lignes
        n = 0
        For Each c In P.Columns(2).Cells
            .Cells(8 + n, 2).Resize(4) = Application.Transpose(c.Resize(, 4))
            n = n + 5
        Next c
        If choix Then .PrintPreview Else .PrintOut
    Next r
End With
End Sub