[Résolu] Plusieurs zones d'impression dans un Array

[Kim75]

Bonjour le forum,

Le but de la macro est d’imprimer des zones d’impressions mises dans un « Array » afin de pouvoir sélectionner celles qu’on veut imprimer

L’impression doit pouvoir se faire de deux manières au choix soit directement vers l’imprimante, soit exportée en un seul et unique fichier pdf

La sélection se fait via des checkbox qui alimentent cet « Array » , mais je rencontre 2 problèmes si quelqu'un pourrait me filer un coup de main :

-1. Le premier est que le preview de l'impression directe se fait en plusieurs sections au lieu d'une seule lorsqu'il y a plusieurs zones à imprimer

-2. Le second est que l'impression pdf ne contient que la dernière zone mise dans l' « Array » , au lieu de toutes les zones incluses normalement

Private Sub PaperPrint_Click()
Dim i As Integer, Cpt As Long, Ar() As String, Clct As Collection, j As Integer, Ctrl As Control
For Each Ctrl In Controls
    If Left(Ctrl.Name, 8) = "CheckBox" Then
        j = j - (Ctrl.Value = False)
        If j = 12 Then
            MsgBox "Oops, aucune feuille n'a été sélectionné !"
            Exit Sub
        End If
    End If
Next Ctrl
Set Clct = New Collection
If CheckBox1.Value = True Then Clct.Add "$A$1:$ET$119"
If CheckBox2.Value = True Then Clct.Add "$A$121:$ET$239"
If CheckBox3.Value = True Then Clct.Add "$A$241:$ET$359"
If CheckBox4.Value = True Then Clct.Add "$A$361:$ET$479"
If CheckBox5.Value = True Then Clct.Add "$A$481:$ET$599"
If CheckBox6.Value = True Then Clct.Add "$A$601:$ET$719"
If CheckBox7.Value = True Then Clct.Add "$A$721:$ET$839"
If CheckBox8.Value = True Then Clct.Add "$A$841:$ET$959"
If CheckBox9.Value = True Then Clct.Add "$A$961:$ET$1079"
If CheckBox10.Value = True Then Clct.Add "$A$1081:$ET$1199"
If CheckBox11.Value = True Then Clct.Add "$A$1201:$ET$1319"
If CheckBox12.Value = True Then Clct.Add "$A$1321:$ET$1439"
Cpt = Clct.Count
ReDim Ar(Cpt)
For i = 1 To Cpt
    Ar(i - 1) = Clct(i)
Next i
Application.ScreenUpdating = False
Me.Hide
For i = 0 To UBound(Ar) - 1
    Sheets("Plans").PageSetup.PrintArea = Ar(i)
    Sheets("Plans").PrintPreview
Next i
Me.Show
Application.ScreenUpdating = True
Set Clct = Nothing
Unload Me
End Sub

Private Sub PdfPrint_Click()
Dim sNomFichierPDF As String, i As Long, Cpt As Long, Ar() As String, Clct As Collection, j As Integer, Ctrl As Control
For Each Ctrl In Controls
    If Left(Ctrl.Name, 8) = "CheckBox" Then
        j = j - (Ctrl.Value = False)
        If j = 12 Then
            MsgBox "Oops, aucune feuille n'a été sélectionné !"
            Exit Sub
        End If
    End If
Next Ctrl
sNomFichierPDF = ThisWorkbook.Path & "\" & "Plans_Etages.pdf"
If Dir(sNomFichierPDF) = "" Then
    Set Clct = New Collection
    If CheckBox1.Value = True Then Clct.Add "$A$1:$ET$119"
    If CheckBox2.Value = True Then Clct.Add "$A$121:$ET$239"
    If CheckBox3.Value = True Then Clct.Add "$A$241:$ET$359"
    If CheckBox4.Value = True Then Clct.Add "$A$361:$ET$479"
    If CheckBox5.Value = True Then Clct.Add "$A$481:$ET$599"
    If CheckBox6.Value = True Then Clct.Add "$A$601:$ET$719"
    If CheckBox7.Value = True Then Clct.Add "$A$721:$ET$839"
    If CheckBox8.Value = True Then Clct.Add "$A$841:$ET$959"
    If CheckBox9.Value = True Then Clct.Add "$A$961:$ET$1079"
    If CheckBox10.Value = True Then Clct.Add "$A$1081:$ET$1199"
    If CheckBox11.Value = True Then Clct.Add "$A$1201:$ET$1319"
    If CheckBox12.Value = True Then Clct.Add "$A$1321:$ET$1439"
    Cpt = Clct.Count
    ReDim Ar(Cpt)
    For i = 1 To Cpt
        Ar(i - 1) = Clct(i)
    Next i
    Application.ScreenUpdating = False
    For i = 0 To UBound(Ar) - 1
        Sheets("Plans").PageSetup.PrintArea = Ar(i)
        Sheets("Plans").ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNomFichierPDF, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Next i
    Application.ScreenUpdating = True
    Set Clct = Nothing
    MsgBox "La sélection de plans a été éditée au format Pdf," & vbCrLf & vbCrLf & "Le fichier Plans_Etages.pdf est dans ce répertoire !", vbOKOnly + vbInformation, "  Information !"
    Unload Me
Else
    MsgBox "Un fichier Plans_Etages.pdf existe dans ce répertoire," & vbCrLf & vbCrLf & "Merci de le renommer ou de le déplacer et de réessayer !", vbOKOnly + vbExclamation, "  Attention !"
End If
End Sub

Cordialement, Kim.

 

[job75]

Bonjour Kim75, Lone-wolf, le forum,

Dans la mesure où comme sur l'exemple les plans ont tous les mêmes dimensions (119 x 150) et se succèdent avec un pas de 120, inutile de se casser la tête à écrire l'Array :

For i = 1 To 12
  If Me("Checkbox" & i) Then z = z & "," & [A1:ET119].Offset(120 * i - 120).Address
Next

Fichier joint.

A+

 

[job75]

Re,

Si maintenant les plans peuvent avoir des hauteurs différentes mais sont toujours suivis d'une ligne colorée :

Sub Zones(pdf As Boolean)
Dim deb&, i&, n As Byte, z$, fichier$, existe As Boolean
deb = 1 'modifiable
With Sheets("Plans")
  For i = deb To .Range("A1", .UsedRange).Rows.Count
    If .Cells(i, 1).Interior.ColorIndex <> xlNone And n < 12 Then
      n = n + 1
      If Me("Checkbox" & n) Then z = z & "," & .Cells(deb, 1).Resize(i - deb, 150).Address
      deb = i + 1
    End If
  Next

Cela prend évidemment un peu plus de temps.

Fichier (2).

En colonne A les cellules doivent être incolores à part celles délimitant les plans.

A+