Résolu Macro excel et pdfcreator

Redba

Nouveau membre
#21
Bonjour a vous.
J'ai lu vous échange et pense que vous pouvez m'aider. je vous expose mon Souci :
J'ai un fichier excel (Pour simplifier) avec 4 colonnes
Colonne A j'ai un numéro 1 à X
Colonne B -> sFichier : j'ai le Nom du PDf (Ou le lien direct sDossierOut & sFichier du type C:\xxxx\fichier.pdf)
Colonne C sDossierOut : le dossier de sortie
Colonne D sFichierFusion : j'ai le nom du fichier = Feuil1.Range("D1").Value.

je souhaites pouvoir selon le cas soit :
* filtrer Manuellement sur la Colonne A et fusionner les Fichiers de la colonne B (obtenu avec le filtre) et le nom de fichier est celui en D
* filtrer automatiquement sur la Colonne A (avec une liste de nombre en colonne E) et fusionner les Fichiers de la colonne B (obtenu avec le filtre) et le nom de fichier est celui en D.

Si vous pouvez m'aider? J'ai trouver un macro pour fusionner suivant une liste. mais elle ne prends pas en compte le filtre. ci dessous :

Option Explicit

Sub combiner_liste_pdf()
Dim sDossierPDF As String
Dim sDossierOut As String
Dim sFichierFusion As String


sDossierPDF = "D:\Users\Redba\Desktop\xxx\"
sDossierOut = "D:\Users\Redba\Desktop\xxxxx\"
sFichierFusion = Feuil1.Range("D1").Value


FusionPDFs sDossierPDF, sDossierOut, sFichierFusion
End Sub

Private Sub FusionPDFs(sPdfDir As String, _
sPdfOutDir As String, _
sFichierOut As String)
Dim bFirst As Boolean
Dim oPDDoc As Object
Dim oTempPDDoc As Object
Dim LastRow As Long
Dim i As Long
Dim sFichier As String

bFirst = True
LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow
sFichier = Feuil1.Range("B" & i)
If bFirst Then
bFirst = False
Set oPDDoc = CreateObject("AcroExch.PDDoc")
oPDDoc.Open sPdfDir & sFichier
Else
Set oTempPDDoc = CreateObject("AcroExch.PDDoc")
oTempPDDoc.Open sPdfDir & "\" & sFichier
oPDDoc.InsertPages oPDDoc.GetNumPages - 1, oTempPDDoc, 0, oTempPDDoc.GetNumPages, 1
oTempPDDoc.Close
End If
Next i

With oPDDoc
.Save 1, sPdfOutDir & "\" & sFichierOut
.Close
End With

Set oPDDoc = Nothing
Set oTempPDDoc = Nothing
End Sub
 

Membres en ligne

Aucun membre en ligne actuellement.

Derniers messages publiés

Statistiques globales

Discussions
863 293
Messages
8 034 492
Membres
1 573 828
Dernier membre
Frankropers SiSi
Haut