XL 2010 Déplacement de fichiers dans des dossiers portant le même nom

[xamenod]

Bonjour,
j'ai récupéré une macro sur ce site et essayé de l'adapter à mes besoins.
Le besoin: déplacer ~9000 fichiers, deux types de produits: des fichiers simples avec extension .ai et d'autres, des compositions INDD, le même nom avec 3 extensions différentes formant le produit.
Le but est de déplacer les fichiers dans des dossiers portant le même nom, j'ai utilisé une macro qui a bien fait son travail pour créer les dossiers.
j'ai adapté cette macro:

Sub DeplacerFichiers()
Dim DosFichiers As String, DosDestination As String
Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim nbcf As Integer, nbcd As Integer
ChDir "J:\DEPLACEMENT_4"
'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")
DosFichiers = "J:\DEPLACEMENT_4"
DosDestination = "J:\DEPLACEMENT_5\" & fichier2
'vérifie que les deux dossiers existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
If Fso.FolderExists(DosDestination) = False Then Exit Sub

'récupère la collection des fichiers
'dans le dossier d'origine

Set Dos = Fso.GetFolder(DosFichiers)

'parcours la collection en recherchant dans le dossier de destination
'le dossier correspondant au numéro du fichier
'si le dossier existe, le fichier est déplacé

For Each Fichier In Dos.Files


nbcf = InStr(Fichier.Name, ".") - 1
fichier2 = Left(Fichier.Name, nbcf)
'If fichier2 = "11_MARCEL_SEMBAT" Then Stop
DosDestination = "J:\DEPLACEMENT_5\" & fichier2
If Fso.FolderExists(DosDestination) = True Then
Fso.MoveFile DosFichiers & "\" & Fichier.Name, Fichier.Name
'Fso.MoveFile Fichier.Name, DosDestination & "\" & Fichier.Name
'Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name
End If

Next Fichier

End Sub

j'ai testé 3 types d'instructions:
la première:
Fso.MoveFile DosFichiers & "\" & Fichier.Name, Fichier.Name
déplace tous les fichiers dans c:\Bibliothèques\Documents

les deux autres :

Fso.MoveFile Fichier.Name, DosDestination & "\" & Fichier.Name
Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name

m'indiquent Erreur d'éxécution '53': Fichier introuvable

Merci pour votre aide.
Bon week-end
Henry

 

[danielco]

Bonjour,

Peut-être :

Fso.MoveFile DosFichiers & "\" & Fichier.Name, DosDestination & "\" & Fichier.Name

au lieu de :

Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name

Cordialement.

Daniel

 

[xamenod]

Bonjour Daniel,
merci de votre aide, j'ai écrit ce que vous m'avez conseillé, sans succès.
j'ai ré-écrit la macro
Sub DEPLACE()
Dim dosfichiers As String
Dim dosdestination As String
'Dim fso As objet
'Dim dos As objet
Dim Fichier As Object
'Dim nbcf As Integer
'Dim nbcd As Integer

ChDir "j:\DEPLACEMENT_4"

'crée l'objet FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
dosfichiers = "J:\DEPLACEMENT_4\"
dosdestination = "J:\DEPLACEMENT_5\" & Fichier2

'vérifie que les deux dossiers existe bien sur le disque
If fso.FolderExists(dosfichiers) = False Then Exit Sub
If fso.FolderExists(dosdestination) = False Then Exit Sub

'récupère la collection des fichiers
'dans le dossier d'origine
Set dos = fso.GetFolder(dosfichiers)

'parcours la collection en recherchant dans le dossier de destination
'le dossier correspondant au numéro du fichier
'si le dossier existe, le fichier est déplacé
For Each Fichier In dos.Files

If fso.FolderExists(dosdestination) = True Then
fso.MoveFile dosfichiers & "\" & Fichier.Name, dosdestination & "\" & Fichier.Name

End If

Next Fichier

End Sub

les fichiers sont bien déplacés mais seulement dans le dossier parent pas dans les dossiers du même nom que les fichiers.

Merci


Bonne soirée

 

[danielco]

Est-ce que le dossier existe ?

Daniel

 

[xamenod]

Si vous parlez du dossier de destination, oui, tous les dossiers de destination ont étés créer à partir d'une liste et d'une macro.
Cordialement
Henry

 

[patricktoulon]

bonjour
je pense que c'est normal l'erreur
tu boucle sur une arborescence de dossier/fichier et tu la change pendant la boucle ,forcement des le premier fichier déplacé l'arborescence ne correspond plus a celle du départ et donc le fichier 2 devient le fichier 1 parce que le 1 est parti
donc VBA ne s'y retrouve plus

1. il te faut d'abords lister dans un array dynamique les chemins complets des fichiers avec DIR
2. boucler sur cet array
3. a chaque tour utiliser name pour changer le chemin

je dis ça je me trompe peut être

 

[xamenod]

Bonjour Patrick,
merci de ton aide, j'ai fini par trouver le problème, il y avait des fichiers en doublons, même nom, même extension, seule la date de création changeait.
la macro copiait l'un des deux et bloquait en trouvant la place déjà prise dans le dossier de destination.
J'ai supprimé les versions les plus anciennes des doublons sur lesquels la macro bloquait et elle a pu faire le travail.
Je pense que je vais ajouter une ligne pour gérer cette problématique.

Demain j'essayerai ta méthode, ne serait-ce que pour m'entraîner à écrire.

Merci pour tes conseils.
Bon week-end.

 

[xamenod]

Bonjour Daniel,
merci pour tes conseils, j'ai fini par trouver le problème, une sombre histoire de doublons au final.
Merci Beaucoup
Bon week-end.