Accueil

 

EnTête d'impression Modification entête Récuperation entête Impression dynamique sans VBA Champ avec lignes vides Imprime un champ nommé Imprime jusqu'au mois en cours Impression dynamique avec VBA Lignes vides dans le champ Impression jusqu'au mois en cours Lignes vides avec formules Masque lignes vides en colonne A Masque lignes vides toutes colonnes

Masque cellules Impression colonne sans vide Impression arrière plan Masque doublons Impression portrait-paysage Imprime onglet choisi dans liste Impression de fiches Impression des fichiers du jour Imprime onglets de l'utilisateur Sauts de page Saut de page pour chaque groupe Saut de page toutes les n lignes Les groupes ne sont pas coupés en 2 Nombre de pages à imprimer Saut de page blocs

PrintOut HpageBreakAdd HpageBreakCount ResetAllPageBreaks

PrintOut

expression.PrintOut(From NuméroPage,To NuméroPage,Copies NombreCopies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName)

ActiveSheet.PrintOut Copies:=2

En-tête d'impression

Modifie l'en-tête avec le contenu d'une cellule

Sur l'exemple, on modifie l'entête d'impression avec le contenu de la cellule A1.

Sub ModifieEnTete()
   ActiveSheet.PageSetup.CenterHeader = [A1]
   ActiveWindow.ActiveSheet.PrintPreview
End Sub

Avec choix de la police:

ActiveSheet.PageSetup.CenterHeader = "&""Verdana,Gras Italique""&12Cegos"

ou

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  If ActiveSheet.Name = "Feuil1" Then
     ActiveSheet.PageSetup.CenterHeader = Sheets("BeforePrint").Range("A1")
  End If
End Sub

Nom du classeur dans le pied de page

Private Sub Workbook_BeforePrint(Cancel As Boolean)
ActiveSheet.PageSetup.CenterFooter = ThisWorkbook.FullName
End Sub

Recupération du texte de l'entête

Un entête est codé sous cette forme: &"Verdana,Gras"&12Cegos

Cette fonction extrait le texte seulement:

Function RecupEntete()
  entete = ActiveSheet.PageSetup.CenterHeader
  p = InStrRev(entete, "&")
  RecupEntete = IIf(p = 0, entete, Mid(entete, p + 3))
End Function

Impression dynamique sans VBA

La zone d'impression s'agrandit automatiquement dès qu’une ligne est ajoutée dans la BD

-Insertion/Nom/Définir
-Zone_d_impression
=DECALER($A$1;;;NBVAL($A:$A);6)

MFC:
Sélectionner A2:A30
Format/Mise en forme conditionnelle/La formule est:
=LIGNE()<=NBVAL($A:$A)

Le champ à imprimer contient des lignes vides

Créer un nom de champ dynamique:

-Insertion/Nom/Définir
-Zone_d_impression
=DECALER($A$1;;;MAX(SI($A$2:$E$1000<>"";LIGNE($A$2:$E$1000);0));5)

MFC:
=LIGNE(A1)<MAX(SI($A$2:$E$1000<>"";LIGNE($A$2:$E$1000);0))

Imprime un champ nommé

Sur cet exemple, on choisit le champ à imprimer dans une liste déroulante.

Noms de champ
Afrique $A$10:$I$15
Europe $A$1:$I$7

Créer un nom de champ dynamique:

Zone_d_impression:=INDIRECT($K$2)

On veut imprimer jusqu'au dernier mois avec au moins une valeur saisie

Créer un nom de champ dynamique:

-Insertion/Nom/Définir
-Zone_d_impression
=DECALER($A$1;;;9;MAX(SI($A$2:$M$9<>"";COLONNE($A$2:$M$9);0)))

Pour colorier les mois qui ont étés saisis:
MFC:
=COLONNE(A1)<=MAX(SI($A$2:$M$9<>"";COLONNE($A$2:$M$9);0))

Impression dynamique avec VBA

Imprime jusqu'à la dernière ligne.

Sub ImpressionDynamique()
  ActiveSheet.PageSetup.PrintArea = [A1].CurrentRegion.Address
  ActiveWindow.SelectedSheets.PrintPreview
End Sub

Le champ à imprimer contient des lignes vides

Sub ImpressionDynamiqueLignesVides()
   lignefin = [A:E].Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
   ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin, 5)).Address
   ActiveWindow.SelectedSheets.PrintPreview
End Sub

On veut imprimer jusqu'au dernier mois avec au moins une valeur saisie

Sub ImpressionDynamiqueColonnesVides()
  ColFin = [2:9].Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious,     LookIn:=xlValues).Column
    ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(9, ColFin)).Address
    ActiveWindow.SelectedSheets.PrintPreview
End Sub

Les lignes avec 0 (résultat de formule) ne doivent pas être imprimées

Sub ImpressionDynamiqueFormules()
  ActiveWindow.DisplayZeros = True
  lignefin = [A:B].Find("0", SearchOrder:=xlByRows, SearchDirection:=xlNext, LookAt:=xlWhole,     LookIn:=xlValues).Row
  If Err = 0 Then
    ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin - 1, 2)).Address
  Else
    ActiveSheet.PageSetup.PrintArea = [A1].CurrentRegion.Address
  End If
  ActiveWindow.SelectedSheets.PrintPreview
End Sub

ou

Sub ImpressionDynamiqueFormules2()
   ActiveWindow.DisplayZeros = False
   lignefin = [A:A].Find("", SearchOrder:=xlByRows, SearchDirection:=xlNext, LookAt:=xlWhole,      LookIn:=xlValues).Row
   ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin - 1, 2)).Address
   ActiveWindow.SelectedSheets.PrintPreview
End Sub

Impression d'un champ sans les lignes vides en colonne A

On masque les lignes vides en colonne A

Sub masqueLignesVides()
   On Error Resume Next
   Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
   lignefin = [A:E].Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious,       LookIn:=xlValues).Row
   ActiveSheet.PageSetup.PrintArea = Range("a1", Cells(lignefin, 5)).Address
   ActiveSheet.PrintPreview                 'ou ActiveSheet.printout
   Range("A:A").EntireRow.Hidden = False
End Sub

Impression d'un champ sans les lignes vides sur toutes les colonnes

On masque les lignes vides sur toutes les colonnes

ImprimeSansVides.xls

Sub MasqueVides()
  Set champ = Range("$A$1:$F$30")
  champ.Find("*", , , , xlByRows, xlPrevious).Offset(1, 0).Select
  n = champ.Columns.Count
  champ.Cells(65000, 1).End(xlUp).Offset(1, 0).Select
  For i = 1 To champ.Rows.Count
    If Application.CountA(champ.Cells(i, 1).Resize(1, n)) = 0 Then
       Union(Selection, champ.Cells(i, 1)).Select
     End If
   Next i
   Selection.EntireRow.Hidden = True
   ActiveSheet.PageSetup.PrintArea = champ.Address
   ActiveWindow.SelectedSheets.PrintPreview
   Cells.EntireRow.Hidden = False
   ActiveSheet.PageSetup.PrintArea = ""
End Sub

Version avec formules dans le champ imprimé

Sub masqueVidesAvecFormules()
  Set champ = Range("$A$1:$F$30")
  champ.Find("*", , , , xlByRows, xlPrevious).Offset(1, 0).Select
  n = champ.Columns.Count
  champ.Cells(65000, 1).End(xlUp).Offset(1, 0).Select
  For i = 1 To champ.Rows.Count
     k = 0
     For Each c In champ.Cells(i, 1).Resize(1, n)
       If c <> 0 And c <> "" Then k = k + 1
     Next c
     If k = 0 Then Union(Selection, champ.Cells(i, 1)).Select
  Next i
  Selection.EntireRow.Hidden = True
  ActiveSheet.PageSetup.PrintArea = champ.Address
  ActiveWindow.SelectedSheets.PrintPreview
  Cells.EntireRow.Hidden = False
End Sub

On veut masquer des cellules à l'impression

On colorie en jaune (36)les cellules qui doivent être masquées à l’impression

Sub ImprimeMasqué2()
  Dim temp(1000), temp2(1000)
  ligne = 1
  For Each c In ActiveSheet.UsedRange
    If c.Interior.ColorIndex = 36 Then
      temp(ligne) = c.NumberFormat
      temp2(ligne) = c.Address
      ligne = ligne + 1
      c.NumberFormat = ";;;"
    End If
Next c
ActiveSheet.PrintPreview
For i = 1 To ligne - 1
   Range(temp2(i)).NumberFormat = temp(i)
Next i
End Sub

Autre solution : Les nos des cellules à masquer sont dans la macro :

Sub ImprimeMasqué()
   Dim temp(1000)
   ligne = 1
   Set champ = Range("B4:B5,C6:C7,D4:D5")
   For Each c In champ
     temp(ligne) = c.NumberFormat
     ligne = ligne + 1
     c.NumberFormat = ";;;"
   Next c
   ActiveSheet.PrintPreview
   ligne = 1
   For Each c In champ
     c.NumberFormat = temp(ligne)
     ligne = ligne + 1
   Next c
End Sub

Imprime chaque colonne sans les lignes vides

Sub imprime()
   ActiveSheet.PageSetup.PrintTitleColumns = "$A:$A"
   n = Range("A5").CurrentRegion.Rows.Count
   For Each c In Range([B3], [B3].End(xlToRight))
     Cells.EntireRow.Hidden = False
     c.Resize(n + 2).Select
     Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
     Selection.PrintPreview ' Selection.Printout
   Next c
   Cells.EntireRow.Hidden = False
End Sub

Imprime un arrière plan

Pour ontenir une image d’arrière-plan:Format /Feuille/Arrière plan

Pour imprimer avec Arrière-Plan

Sub ImpressionAvecFond()
   Range("A1").CurrentRegion.Select
   Selection.CopyPicture ' Copie la zone
   ActiveSheet.Paste Destination:=ActiveSheet.Range("A1") 'crée un shape
   ActiveSheet.PageSetup.PrintArea = Selection.Address
   ActiveWindow.SelectedSheets.PrintPreview
   ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
End Sub

Les doublons en colonne A sont masqués à l'impression

Sub masqueDoublons()
   [A2].Select
   Do While ActiveCell <> ""
      m = ActiveCell
      ActiveCell.Offset(1, 0).Select
      Do While ActiveCell = m
        ActiveCell.Font.ColorIndex = 2
        ActiveCell.Offset(1, 0).Select
      Loop
   Loop
   ActiveSheet.PrintPreview
   Range("A2", [A2].End(xlDown)).Font.ColorIndex = 0
End Sub

Imprime une zone en portrait et l'autre en paysage

ActiveSheet.PageSetup.PrintArea = "B3:C14"
ActiveSheet.PageSetup.Orientation = xlPortrait
ActiveSheet.PrintPreview ' ou ActiveSheet.printout
ActiveSheet.PageSetup.PrintArea = "B16:F22"
ActiveSheet.PageSetup.Orientation = xlLandscape
ActiveSheet.PrintPreview '' ou ActiveSheet.printout

Imprime l'onglet choisi

Private Sub Worksheet_Activate()
  For s = 1 To Sheets.Count
    Cells(s + 1, 6) = Sheets(s).Name
  Next s
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    Application.EnableEvents = False
    onglet = Range("B2")
    Sheets(onglet).PrintPreview
    Application.EnableEvents = True
  End If
End Sub

Sauts de page

HPageBreaks.Add
HPageBreaks.Count
ResetAllPageBreaks

Pour ajouter un saut de page à la position de la cellule active

ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell

Insère un saut de page à chaque changement de groupe

Sub SautPageGroupe()
   ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
   ActiveSheet.ResetAllPageBreaks ' raz
   For i = 2 To [A65000].End(xlUp).Row
     If Cells(i + 1, 2) <> Cells(i, 2) Then
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 1, 1)
     End If
   Next
   ActiveSheet.PrintPreview
   'ActiveSheet.ResetAllPageBreaks ' raz
End Sub

Insère un saut de page toutes les 15 lignes

Sub SautPage()
  ActiveSheet.ResetAllPageBreaks ' raz
  h = 15 ' hauteur de page
  [A2].Select
  Do While ActiveCell.Row < [A65000].End(xlUp).Row
    ActiveCell.Offset(h, 0).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Loop
  [A2].Select
End Sub

Les sauts de page ne coupent pas un groupe en 2

Sub SautPage2()
  ActiveSheet.ResetAllPageBreaks ' raz
  h = 15 ' hauteur de page
  [b2].Select
  Do While ActiveCell.Row < [A65000].End(xlUp).Row
    ActiveCell.Offset(h, 0).Select
    tém = True
    d = -1
    Do While tém
      If ActiveCell.Offset(d, 0) <> ActiveCell Then
         tém = False
      Else
         d = d - 1
      End If
   Loop
   If (-d) < h Then ActiveCell.Offset(d + 1, 0).Select
   ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
   Loop
   [A2].Select
End Sub

Nombre de pages à imprimer

Pour la page active

Function NbPages()
   NbPages = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1)
End Function

Pour plusieurs pages

Sub PlusieursPages()
   tpage = 0
   For s = 1 To 3
      tpage = tpage + (Sheets(s).HPageBreaks.Count + 1) * (Sheets(s).VPageBreaks.Count + 1)
   Next s
   MsgBox tpage
End Sub

Insère des sauts de page entre des blocs

On impime plusieurs blocs par page. Les blocs ne doivent pas être coupés.
On cherche une plage vide pour insérer le saut de page.

Sub essai_JB()
  ActiveSheet.ResetAllPageBreaks ' raz
  h = 60 ' hauteur de page
  nlv = 2 ' Nombre de lignes vides
  lg = 8 ' largeur
  [A3].Select
  Do While ActiveCell.Row < [A65000].End(xlUp).Row
    ActiveCell.Offset(h, 0).Select
    tém = True
    d = 0 ' décalage
    Do While tém And d > -h ' on cherche une plage vide :nlv * lg
       If Application.CountA(ActiveCell.Offset(d, 0).Resize(nlv, lg)) = 0 Then
         tém = False
       Else
         d = d - 1
       End If
    Loop
    If d > -h Then ActiveCell.Offset(d, 0).Select ' nb lignes du bloc >h
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Loop
  [A3].Select
End Sub  

Impression d’un TCD

Imprime les différents statuts.

Sub edition()
   ActiveSheet.PageSetup.PrintArea = "$J$1:$M$8"
   For s = 1 To Sheets(1).PivotTables(1).PivotFields("statut").PivotItems.Count
     statut = ActiveSheet.PivotTables(1).PivotFields("statut").PivotItems(s)
     ActiveSheet.PivotTables(1).PivotFields("Statut").CurrentPage = statut
     ActiveWindow.SelectedSheets.PrintPreview ' ou PrintOut
   Next s
End Sub

Impression des fiches à partir d'une BD

Chaque ligne de la BD est transféré en J1:G1 puis imprimé.

Sub ImprimeBD()
  Range("a2").Select
  Do While ActiveCell <> ""
    Range(ActiveCell, ActiveCell.Offset(0, 6)).Copy Range("j1")
    ActiveSheet.PrintPreview ' ou ActiveSheet.PrintOut
    ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Imprime les fichiers du jour programmé

Les fichiers dont la date d'impression est égale à la date du jour sont imprimés.

Sub EditionDate()
  ChDir ActiveWorkbook.Path
  Application.DisplayAlerts = False
  Range("a2").Select
  Do While ActiveCell <> ""
    nf = ActiveCell
    If Date = ActiveCell.Offset(0, 1) And ActiveCell.Offset(0, 2) = "" Then
      On Error Resume Next
      Workbooks.Open Filename:=nf
      If Err = 0 Then
        ActiveWindow.SelectedSheets.PrintPreview
       'ActiveWindow.SelectedSheets.PrintOut Copies:=1
        ActiveWorkbook.Close
        ActiveCell.Offset(0, 2) = "ok"
        ActiveCell.Offset(0, 3) = ""
     Else
        ActiveCell.Offset(0, 3) = "Inconnu"
        End If
    End If
    ActiveCell.Offset(1, 0).Select
  Loop
End Sub

Imprime les feuilles de l'utilisateur réseau

Pour les classeur partagé, cette macro n'imprime que les onglets de l'utilisateur.

Sub Imprime()
  Dim a()
  Sheets("editions").Select
  p = Application.Match(Environ("username"), [A1:M1], 0)
  n = Cells(65000, p).End(xlUp).Row - 1
  ReDim a(1 To n)
  For i = 1 To n
    a(i) = Cells(i + 1, p)
  Next i
  Sheets(a).PrintPreview
End Sub