création répertoire avec copie de fichier

[saintex95]

Bonjour,

J'ai des fichiers dans un répertoire et à partir de ces noms de fichiers je veux créer un répertoire portant le nom de chaque fichier avec copie du fichier dans ce répertoire.

Je m'explique:

j'ai 415 fichiers de format PDF dans un répertoire.
Je veux créer 415 répertoires avec comme intitulé le nom de chaque fichier, donc 415 répertoires.
Je veux copier ces 415 fichiers dans chaque répertoire associé en fonction du nom.

Merci.

 

[camarchepas]

Re : création répertoire avec copie de fichier

Bonjour ,

le code devrait ressembler à ceci .

Attention , modifier Chemin et CheminCible selon votre configuration

Sub Déplace()
Dim Chemin As String, NomFichier As String
Dim CheminCible As String
Chemin = "c:\temp\"
CheminCible = "c:\temp\bis\"

NomFichier = Dir(Chemin & "*.pdf")
Do
ChDir (CheminCible)
MkDir (Replace(NomFichier, ".pdf", ""))
Name Chemin & NomFichier As CheminCible & Replace(NomFichier, ".pdf", "") & "\" & NomFichier
NomFichier = Dir
Loop Until NomFichier = ""
End Sub

 

[saintex95]

Re : création répertoire avec copie de fichier

Bonjour,

Merci beaucoup

je vais tester.

 

[Roland_M]

Re : création répertoire avec copie de fichier

bonjour à tous,

salut à toi camarchepas !

@saintex95
excuses ma curiosité, mais pourquoi un répertoire pour un fichier et avec le même nom ?
pour la liste des fichiers eux mêmes ça ne va pas être marrant !?

 

[camarchepas]

Re : création répertoire avec copie de fichier

Bonjour Roland ,

Les voix de Saint Ex sont impénétrables .

Peut être un spécialiste de construction de labyrinths ......

 

[saintex95]

Re : création répertoire avec copie de fichier

Bonjour tout le monde.

Eh ben non je ne construit pas des labyrinthe(s)

En fait je vais répondre à votre curiosité, je vous dois bien cela si la macro marche.

Je suis pilote d'ULM et j'utilise un Logiciel Aéronav Pro sur un Ipad.
Sur ce logiciel j'ai la possibilité d'afficher des cartes de terrain au format PDF à la seule condition qu'elle soit dans un répertoire portant le nom du terrain c'est à dire le nom du fichier(le fichier et le répertoire dans lequel se trouve le fichier doivent avoir le même nom)
Mais ces fichiers je les récupère par un programme sur un site officiel de la Direction de l’aviation civile régulièrement pour avoir les cartes à jour.
Et c'est là que j'ai 415 fichiers qui correspondent aux 415 cartes des terrains d'aviation de France.

Donc je dois transférer ces 415 fichiers dans 415 répertoires portant le nom du fichier lui même.

Voilà vous savez tout de mon problème.

 

[Roland_M]

Re : création répertoire avec copie de fichier

bonsoir à tous,

alors OK !
voir cette macro qui fonctionne pour l'avoir testée !
on error afin de poursuivre si le répertoire existe déjà !
(c'est le même principe que camarchepas avec qq petites différences)

Sub DeplaceFichiers()
Extention$ = "pdf"             '< extention sans le point
RepSource$ = "E:\EssaiSource\" '< ici l'emplacement de tout les pdf
RepDestin$ = "E:\EssaiDestin\" '< ici la destination où seront créés les rep et les fichiers déplacés

On Error Resume Next
Fich$ = Dir(RepSource$ & "*." & Extention$)
Do While Fich$ <> ""
 I = InStrRev(Fich$, ".")
 If I Then
    If LCase(Mid(Fich$, I + 1)) = LCase(Extention$) Then
       Rep$ = Left(Fich$, I - 1)
       NewRep$ = RepDestin$ & Rep$
       MkDir NewRep$
       Name RepSource$ & Fich$ As NewRep$ & "\" & Fich$
    End If
 End If
 Fich$ = Dir
Loop
End Sub

 

[gbinforme]

Re : création répertoire avec copie de fichier

bonsoir à tous,

Comme je suis un fan de Saint-Ex, j'ai regardé ce poste et j'ai pensé que saintex95 ne voulait pas déplacer ses fichiers mais voulait créer une nouvelle structure en gardant l'ancienne alors je lui propose cette macro qui copie les PDF dans la nouvelle structure. Si les cartes sont mises à jour elles sont ainsi transférées dans la nouvelle structure.

Sub ventile_copie() ' copie des pdf sur répertoires
Dim r_ori As String, fic As String
Dim r_cbl As String, rep As String, fs As Object
r_ori = "C:\chemin_origine\"    ' à modifier
r_cbl = "C:\chemin_cible\"      '     "
Set fs = CreateObject("Scripting.FileSystemObject")
fic = Dir(r_ori & "*.pdf")
On Error Resume Next    ' répertoires existant en mise à jour
While fic <> ""
    rep = Left(fic, Len(fic) - 4)
    MkDir r_cbl & rep
    Err.Clear
    fs.CopyFile r_ori & fic, r_cbl & rep & "\" & fic
    fic = Dir
Wend
End Sub

 

[Roland_M]

Re : création répertoire avec copie de fichier

re

bonjour gbinforme, peut être bien que copier !?
mais il parle de "... transférer ces 415 fichiers ..." !?

au cas où, idem en copier:

Sub CopierFichiers() ' copie fichiers en créant un répertoire à chacun
Extention$ = "pdf"             '< extention sans le point
RepSource$ = "E:\EssaiSource\" '< ici l'emplacement de tout les pdf
RepDestin$ = "E:\EssaiDestin\" '< ici la destination où seront créés les rep et les fichiers copiés
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Fich$ = Dir(RepSource$ & "*." & Extention$)
Do While Fich$ <> ""
 I = InStrRev(Fich$, ".")
 If I Then
    If LCase(Mid(Fich$, I + 1)) = LCase(Extention$) Then
       REP$ = Left(Fich$, I - 1)
       NewRep$ = RepDestin$ & REP$
       MkDir NewRep$
       FSO.CopyFile RepSource$ & Fich$, NewRep$ & "\" & Fich$
    End If
 End If
 Fich$ = Dir
Loop
Set FSO = Nothing
On Error GoTo 0: Err.Clear
End Sub

 

[saintex95]

Re : création répertoire avec copie de fichier

Bonjour,

Étant débutant en macro excel je n'arrive pas à mettre en œuvre la macro(voir P.J.).

J'ai recopié dans microsoft visual basic le code et déboguer.

la commande débogage - > compile VBAProject m'envoie un message

erreur de compilation erreur de syntaxe

 

[camarchepas]

Re : création répertoire avec copie de fichier

RE ,

I = InStrRev(Fich$, ".") et valides la ligne par entrée.

Ou fait comme moi un copier coller , y'a pas d'anomalie

 

[Roland_M]

Re : création répertoire avec copie de fichier

re

bizarre car il n'y a pas d'erreur dans le code !?

tu fais l'exécution sur la macro au pas à pas avec F8
et tu dis sur quelle ligne ça bloque !

EDIT:
erreur probable du chemin !?

remplaces C:\Utilisateurs...
par C:\Users\ ...