Bonjour à tous,

La macro ci- après me permet d'exporter mon fichier Excel vers un PDF (Avec choix des onglets à exporter ) en masquant les lignes pour les colonnes ( Roc et Cor) qui affichent simultanément 0 .

Le petit soucis, c'est que lors de la sélection de plusieurs feuilles pour export , la macro exporte une à une les feuilles.

Je voudrais que cet export se fasse plutôt en seul fichier unique mais je n'arrive pas à modifier la macro pour que ça se fasse.

je sollicite donc votre assistance pour m'aider à résoudre cette difficulté

Voici le code à modifier

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
Option Explicit
Dim i As Integer, n As Integer, S As Integer
Dim FeuilleActuel As String
Dim MySheet As Worksheet
 
Private Sub CmdFermer_Click()
Unload Me
End Sub
 
Sub MarqueDocumentsListbox()
Dim OpenWorkbook As Workbook
For Each OpenWorkbook In Application.Workbooks
If OpenWorkbook.IsAddin Then
Else
If OpenWorkbook.Name = "Perso.xls" Then
Else
LbClasseurs.AddItem (OpenWorkbook.Name)
End If
End If
Next OpenWorkbook
End Sub
 
Private Sub CmdImprimer_Click()
Dim j As Integer, Cellule_Roc As Range, Drapeau As Boolean
 
Application.ScreenUpdating = False
 
For i = 0 To LbFeuilles.ListCount - 1
    If LbFeuilles.Selected(i) = True Then
    Application.StatusBar = "Impression: " & LbFeuilles.List(i)
    Application.DisplayAlerts = False
 
    ' Recherche si la feuille contient "Roc" et "Cor"
    For Each Cellule_Roc In Sheets(LbFeuilles.List(i)).UsedRange
        If Cellule_Roc = "Roc" And Cellule_Roc.Offset(0, 1) = "Cor" Then
            Drapeau = True
            GoTo Etiquette
        End If
    Next
 
Etiquette:
    ' Masquage de certaines lignes avant impression si la feuille contient "Roc" et "Cor"
    If Drapeau = True Then
        For j = Cellule_Roc.Row + 1 To Cellule_Roc.End(xlDown).Row
            If Sheets(LbFeuilles.List(i)).Cells(j, Cellule_Roc.Column) = 0 And Sheets(LbFeuilles.List(i)).Cells(j, Cellule_Roc.Column + 1) = 0 Then
                Sheets(LbFeuilles.List(i)).Cells(j, 1).EntireRow.Hidden = True
            End If
        Next j
        Drapeau = False
    End If
 
    Sheets(LbFeuilles.List(i)).PrintOut
 
    ' Réouverture des lignes masquées
    Sheets(LbFeuilles.List(i)).Cells.EntireRow.Hidden = False
 
    End If
Next i
 
'Application.DisplayAlerts = True
Unload Me
Application.StatusBar = False
Application.ScreenUpdating = True
'Cmdfermer.
End Sub
 
Private Sub CmdSelectionImprimante_Click()
Application.Dialogs(xlDialogPrinterSetup).Show
End Sub
 
Private Sub CmdSupprimer_Click()
Dim Msg, Style, Title, Response
Unload Me 'FrmImprime
For i = 0 To LbFeuilles.ListCount - 1
    If LbFeuilles.Selected(i) = True Then
    With ActiveWorkbook.Sheets(LbFeuilles.List(i))
'Faites quelque chose
    Style = vbYesNo + vbQuestion + vbDefaultButton1
    Title = "Impression de Feuilles de calcul "
    Msg = " Supprimez Feuille  " & (LbFeuilles.List(i)) & " ? " & "     "
    Response = MsgBox(Msg, Style, Title)
    If Response = vbNo Then GoTo next0
    If Worksheets(LbFeuilles.List(i)).Visible = False Then
    MsgBox " Feuille Cachée  ", vbInformation, "Impression de Feuilles de calcul"
    Worksheets(LbFeuilles.List(i)).Visible = True
    Application.DisplayAlerts = False
    Worksheets(LbFeuilles.List(i)).Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    Else
    Application.DisplayAlerts = False
    Worksheets(LbFeuilles.List(i)).Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
 End If
next0:
  End With
'La fin fait quelque chose
  End If
Next
Application.ScreenUpdating = True
End Sub
 
'Teste
'Sub NbrsFeuilles()
'Dim ws As Worksheet
'FrmImprime.LbFeuilles.Clear
'With FrmImprime
'.LblNombreFeuilles.Caption = "Nbrs de Feuilles: " & n
'End With
'For Each ws In Worksheets
'FrmImprime.LbFeuilles.AddItem ws.Name
'Next ws
'FrmImprime.Show
'End Sub
 
Private Sub CmdWsToutesSelection_Click()
For i = 0 To LbFeuilles.ListCount - 1
LbFeuilles.Selected(i) = True
Next i
End Sub
 
Private Sub CmdWsInverseSelection_Click()
For i = 0 To LbFeuilles.ListCount - 1
If LbFeuilles.Selected(i) = False Then
LbFeuilles.Selected(i) = True
Else
LbFeuilles.Selected(i) = False
End If
Next i
End Sub
 
Private Sub CmdWsAucuneSelection_Click()
For i = 0 To LbFeuilles.ListCount - 1
LbFeuilles.Selected(i) = False
Next i
End Sub
 
Private Sub LbFeuilles_Change()
Application.ScreenUpdating = False
n = 0
For S = 0 To LbFeuilles.ListCount - 1
If LbFeuilles.Selected(S) = True Then n = n + 1
Next S
LblNombreFeuilles.Caption = "Nbrs de Feuilles: " & n
End Sub
 
Private Sub LbClasseurs_Change()
On Error Resume Next
FeuilleActuel = ActiveSheet.Name
Workbooks(LbClasseurs.Value).Activate
Call MarqueListeSheet
Call MarqueFeuillesListbox
LbFeuilles.Value = FeuilleActuel
End Sub
 
Sub MarqueListeSheet()
On Error Resume Next
Dim i As Integer
i = 1
For i = 1 To LbFeuilles.ListCount + 1
LbFeuilles.RemoveItem (LbFeuilles.ListIndex = i)
Next i
On Error GoTo 0
End Sub
 
Sub MarqueFeuillesListbox()
Dim AvailableSheet As Worksheet
 
 
For Each AvailableSheet In ActiveWorkbook.Worksheets
    If AvailableSheet.Name <> "Pomme" And AvailableSheet.Name <> "Raisin" And AvailableSheet.Name <> "Clémentine" And AvailableSheet.Name <> "Melon" And AvailableSheet.Name <> "Pastèque" Then
        If AvailableSheet.Visible = xlSheetVisible Then
            LbFeuilles.AddItem (AvailableSheet.Name)
        'Else
        End If
    End If
Next AvailableSheet
 
On Error GoTo 0
 
End Sub
 
Private Sub UserForm_Initialize()
Call MarqueDocumentsListbox
Application.EnableEvents = False
LbClasseurs.Value = ActiveWorkbook.Name
Application.EnableEvents = True
End Sub