XL 2016 *** RESOLU MERCI :)*** Impression personnalisée.

job75 à dit:

Sur le fichier du post #68 beaucoup de lignes à imprimer sont disjointes.

Avec la macro "Imprimer" il y aura alors beaucoup de pages à imprimer.

Executez la macro "Fichier_PDF" puis ouvrez et imprimez le fichier PDF créé.

Cliquez pour agrandir...

job75 à dit:

Bon j'ai modifié la macro "Imprimer" en ajoutant une feuille vierge auxiliaire :

VB:

Sub Imprimer()
Dim T As Range, rc&, i&, dat, coll As New Collection, P As Range, j&
Set T = [Tableau3] 'tableau structuré
rc = T.Rows.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To rc
    If Not T.Rows(i).Hidden Then 'lignes visibles
        dat = T(i, 2)
        On Error Resume Next
        coll.Add dat, CStr(dat)
        If Err = 0 Then
            Set P = T.Rows(i)
            For j = i + 1 To rc
                If Not T.Rows(j).Hidden Then If T(j, 2) = dat Then Set P = Union(P, T.Rows(j))
            Next j
            With Sheets.Add(, Sheets(Sheets.Count), 1) 'ajoute une feuille vierge auxiliaire
                T.Rows(0).Copy .Cells(1)
                For j = 1 To .UsedRange.Columns.Count: .Columns(j).ColumnWidth = T(1, j).ColumnWidth: Next j 'largeurs des colonnes
                P.Copy
                .Cells(2, 1).PasteSpecial xlPasteValues 'collage spécial
                .Cells(2, 1).PasteSpecial xlPasteFormats
                .UsedRange.RowHeight = 30 'hauteur des lignes
                With .PageSetup
                    .PrintTitleRows = "$1:$1"
                    .Orientation = xlLandscape
                    .Zoom = False
                    .FitToPagesWide = 1 '1 page en largeur
                    .FitToPagesTall = 2 '2 pages en hauteur
                End With
                '.PrintOut 'pour imprimer ôter l'apostrophe et en mettre une devant la ligne suivante
                Application.ScreenUpdating = True: .PrintPreview: Application.ScreenUpdating = False 'aperçu
                .Delete 'supprime la feuille auxiliaire
            End With
        End If
    End If
Next i
T.Parent.Activate 's'il y a plusieurs feuilles
End Sub

Cliquez pour agrandir...