XL 2019 Rassembler les fichiers .pdf dans un seul dossier

[Amilo]

Bonjour à tous,

J'ai un fichier Excel avec le chemin de tous les .pdf éparpillés dans différents dossiers (voir les chemins dans le fichier Excel)
Je souhaiterais copier et rassembler tous les fichiers .pdf idans un dossier unique

Le dossier unique nommé "Factures" sera sous D:\Clients\2020\Factures

Merci d'avance pour votre aide

Cordialement

 

[kiki29]

Salut, à adapter à ton contexte

 

[Amilo]

Bonjour kiki29,

Merci pour votre réponse,
Je suis sorti de chez moi et vous réponds de mon mobile,
Je testerai ce soir â mon retour et vous tiendrai informé

A bientôt
Bonne journée

 

[fanch55]

Bonjour à Tous,

A essayer (copie des fichiers et non déplacer ) :

 

[job75]

Bonjour Amilo, kiki29, fanch55,

Pas encore regardé les solutions mais avec FileCopy c'est bien simple :

Sub Rassembler()
Dim dossier$, c As Range, n&
dossier = "D:\Clients\2020\Factures" 'dossier de destination
For Each c In [Tableau1] 'tableau structuré
    If Right(c, 4) = ".pdf" And Dir(c) <> "" Then
        n = n + 1
        FileCopy c, dossier & Mid(c, InStrRev(c, "\"))
    End If
Next
MsgBox n & " fichier(s) PDF rassemblé(s)", , "Rassembler PDF"
End Sub

A+

 

[job75]

La solution précédente fait du copier-coller : les fichiers restent dans leurs dossiers d'origine.

Si l'on veut faire du couper-coller on utilisera cette macro qui déplace les fichiers :

Sub Deplacer()
Dim dossier$, c As Range, n&
dossier = "D:\Clients\2020\Factures" 'dossier de destination
For Each c In [Tableau1] 'tableau structuré
    If Right(c, 4) = ".pdf" And Dir(c) <> "" Then
        n = n + 1
        Name c As dossier & Mid(c, InStrRev(c, "\"))
    End If
Next
MsgBox n & " fichier(s) PDF déplacé(s)", , "Déplacer PDF"
End Sub

 

[Amilo]

Bonjour fanch55, job75, le forum,
Re kiki29,

Merci beaucoup à vous également pour votre proposition,
Je viens de tester toutes les solutions :

@kiki29 : j'ai malheureusement un message d'erreur, je vous ai mis une capture d'écran du message. Je ne sais pas si c'est lié à la version "Kernel32....
Par ailleurs, je souhaitais "Copier/Coller", mais probablement que votre fichier est prévu pour "Déplacer".

@fanch55 : cela fonctionne bien, cependant les fichiers sont sans extension
Je dois ajouter manuellement ".pdf" derrière chaque fichier pour que le logo soit au nom de Adobe,

@job75 : merci c'est parfait à un détail près..., le "msgbox" indique "13 fichier(s) PDF rassemblé(s)" alors que j'en compte 12 au final, mais pas très grave

Cordialement

 

[kiki29]

Salut, à toi de voir et appliquer : Développer avec Office 64 bits

Même Microsoft déconseillait l'installation d'une version 64 bits d'Office.

Office 32 bits est recommandé pour la plupart des utilisateurs
Nous recommandons la version 32 bits d’Office pour la plupart des utilisateurs, car elle offre une plus grande compatibilité avec la plupart des autres applications, en particulier les compléments tiers. C’est la raison pour laquelle la version 32 bits d’Office est installée par défaut, même sur les systèmes d’exploitation Windows 64 bits. Sur ces systèmes, le client Office 32 bits est pris en charge en tant qu’installation Windows-32-on-Windows-64 (WOW64). WOW64 est l’émulateur x86 qui permet l’exécution de façon transparente des applications Windows 32 bits sur les systèmes Windows 64 bits. Cela permet aux utilisateurs de continuer à utiliser les contrôles ActiveX et les compléments COM Microsoft avec la version 32 bits d’Office.

 

[fanch55]

Bonsoir,
Exact, emploi d'une propriété non idoine ...
la sub ci-dessous devrait fonctionner correctement :

Sub Copier_Pdf()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

    Target_Folder = "D:\Clients\2020\Factures\"
    
    [Tableau1[Chemin]].Columns.AutoFit
    
    For Each Elem In [Tableau1[Chemin]]
        Source = Elem.Text
        If FSO.fileexists(Source) Then
            Nom = FSO.getfilename(Source)
            Target = Target_Folder & Nom
            If FSO.folderexists(Target_Folder) Then
                Msg = IIf(FSO.fileexists(Target), "Remplacé: ", "Copié: ") & Target
                FileCopy Source, Target
            Else
                Msg = "Dossier Cible inexistant"
            End If
        Else
            Msg = "Fichier Inexistant"
        End If
        Elem.Offset(, 1) = Msg
    Next
    
    [Tableau1[Rapport]].Columns.AutoFit
    
Set FSO = Nothing
End Sub

 

[Amilo]

Re kiki29 ,fanch55 ,

@kiki29 : cela devrait donc fonctionner au travail car nous nous avons Office 32, je ferai un essai sur un fichier test, mais comme dit, je cherche à Copier/Coller des fichiers.
Je regarderai toutes les possibilités de votre fichier, il me sera utile en d'autres occasions et merci encore.

@fanch55 : j'ai l'impression que vous avez indiqué le même code que dans votre précédent fichier, aussi je ne vois aucun changement…..

Cordialement

 

[job75]

@job75 : merci c'est parfait à un détail près..., le "msgbox" indique "13 fichier(s) PDF rassemblé(s)" alors que j'en compte 12 au final, mais pas très grave

Le comptage porte sur les fichiers des dossiers d'origine et il est possible qu'il y ait des doublons...

Les fichiers en doublon ne peuvent donner au final qu'un seul fichier dans le dossier de destination.

 

[Amilo]

Bonjour job75,

Je n'avais pas pensé à vérifier les doublons, vous avez raison la facture n° 243 était en doublon

En réalité, il est normalement pas impossible d'avoir de doublons car le numéro est automatiquement incrémenté par le logiciel

Merci encore

Bonne journée

 

[job75]

Bonjour Amilo, le forum,

Pour compter les fichiers PDF créés on peut utiliser le Dictionary, fichier (2) :

Sub Rassembler()
Dim dossier$, d As Object, c As Range, nomfich$, n&
dossier = "D:\Clients\2020\Factures" 'dossier de destination
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In [Tableau1] 'tableau structuré
    nomfich = Dir(c)
    If Right(c, 4) = ".pdf" And nomfich <> "" Then
        d(nomfich) = "" 'élimine les doublons
        n = n + 1
        FileCopy c, dossier & "\" & nomfich
    End If
Next
MsgBox d.Count & " fichier(s) PDF créé(s) avec " & n & " d'origine", , "Rassembler PDF"
End Sub

Bonne journée.

 

[fanch55]

@fanch55 : j'ai l'impression que vous avez indiqué le même code que dans votre précédent fichier, aussi je ne vois aucun changement…..

Étonnant, j'ai remplacé la méthode Fso.getbasename (qui donne le nom du fichier sans son extension) par Fso.getfilename qui indique le nom du fichier en entier .

Ci-joint le fichier avec tous les rapports pour curiosité

 

[Amilo]

Bonjour kiki29, fanch55, job75, le forum,

Un grand merci à vous pour vos solutions très simples d'utilisation et qui fonctionnent parfaitement,

@kiki29 , merci pour le 2ème fichier pour un Copier/Coller des fichiers,
J'ai pu le tester au travail sur Office 32 bits et il fonctionne très bien,
J'ai vu que celui-ci crée un nouveau dossier "Arrivée_PDFs"

@fanch55 , désolé effectivement votre code de votre fil #9 copie bien les fichiers avec leur extension, j'ai été trop vite dans mes tests .
Merci également pour votre dernier message avec le msgbox assez complet en information

@job75 , merci aussi pour cette autre version avec un msgbox permettant de déceler un écart avec les fichiers d'origines,
Je suis surpris qu'avec aussi peu de lignes de code, on puisse arriver à un tel résultat et gagner un temps considérable.

En tout cas j'ai l'embarras du choix avec 2 manières différentes de faire (celle de kiki29 est une version différente de celles de fanch55 et job75) et plusieurs versions de msgbox

Merci encore à vous tous

Cordialement