Vba excel impression - faire tenir les données sur moins de pages

Commenter

Contenu du snippet

Imaginons que sous Excel, vous ayez plein de lignes à imprimer, que tout celà tienne sur plusieurs pages.
Avec cette procédure, vous faites tenir tout çà sur moins de pages.

En utilisant les limites d'impression des pages Excel, on redécoupe les tableaux de données pour qu'ils se placent les uns à coté des autres, et prennent ainsi moins de place à l'impression.

Source / Exemple : 


Sub DispatchRowsToColumns()
Dim rCol As Range
Dim rCell1 As Range, rCell2 As Range
Dim i As Integer, iPBcount As Integer
Dim Sht As Worksheet

Application.ScreenUpdating = False

Set Sht = ActiveSheet
Set rCol = Sht.UsedRange.Columns(1)

     Sht.PageSetup.PrintArea = ""
     Sht.PageSetup.Zoom = 100
     ActiveWindow.View = xlPageBreakPreview

' On compte le nombre de pages nécessaires à l'impression
iPBcount = Sht.HPageBreaks.Count

 On Error Resume Next
 ' Tant qu'il y a des page breaks, on boucle
    For i = 1 To iPBcount
        ' On positionne une cellule au début d'une page
        Set rCell1 = Sht.HPageBreaks(i).Location
        ' On positionne une deuxième cellule au début de la page suivante (-1 case),
        ' c'est-à-dire à la fin de la page courante
        Set rCell2 = Sht.HPageBreaks(i + 1).Location.Offset(-1, 0)
            If rCell2 Is Nothing Then
                ' On se trouve sur la dernière page. On colle tout le reste
                ' dans la colonne suivante.
                Range(rCell1, rCol.Cells(65536, 1).End(xlUp)).Cut _
                 Destination:=Sht.Cells(1, i + 1)
            Else
                ' On coupe la selection, et on la colle à partir de la
                ' ligne 1, dans la colonne suivante.
                Range(rCell1, rCell2).Cut Destination:=Sht.Cells(1, i + 1)
            End If
        ' C'est fini, on nettoie tout !
        Set rCell1 = Nothing
        Set rCell2 = Nothing
    Next i
  On Error GoTo 0
  
  ActiveWindow.View = xlNormalView
  Application.ScreenUpdating = True
  Sht.DisplayPageBreaks = False
  Application.Goto rCol.Cells(1, 1), True
  Set rCol = Nothing
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (econs)