Déplacer des fichiers en masse dans des répertoires avec une boucle ?

KROMS

XLDnaute Nouveau
Bonjour à tous,

Une question qui va vous paraître enfantine j'imagine bien...

J'ai 10 000 fichiers .txt ou .htm que je souhaite déplacer par lot de 500 dans des sous-dossiers d'un répertoire.

En l'occurrence, les 500 premiers fichiers dont déplacés dans un dossier "lot1", les 500 suivants dans un dossier "lot2" etc.

Merci de votre aide à tous, cela fait des heures que je cherche, même si déjà j'ai trouvé comment créer des répertoires en nombre...
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Salut Kroms,

Tu peux essayer ce script. A noter que je ne l'ai pas testé (je n'ai pas 10 000 fichiers sous la main :) ), et qu'il n'y a pas de gestion d'erreur (répertoires existant déjà, etc...):

VB:
'Auteur: Theze, [url]www.developpez.net[/url]
 'adapté par mes soins pour tes besoins :)
 
Sub Deplacer()
 
'A adapter
    DeplacerFichiers "D:\DossierOrigine\", "D:\Lot\"
 
End Sub
 
Private Sub DeplacerFichiers(DosFichiers As String, _
                             DosDestination As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim Fichier As Object
    Dim i as Long
    Dim j as Integer
 
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    'vérifie que le dossier d'origine existe bien sur le disque
    If Fso.FolderExists(DosFichiers) = False Then Exit Sub
    'If Fso.FolderExists(DosDestination) = False Then mkdir(DosDestination)
 
    'récupère la collection des fichiers
    'dans le dossier d'origine
    Set Dos = Fso.GetFolder(DosFichiers)
 
        'parcour la collection
        'si le dossier n'existe pas, le dossier est créé et le fichier est déplacé
        For Each Fichier In Dos.Files
            i=i+1
            If i>500 Then DosDestination=DosDestination & j+1
                If Fso.FolderExists(DosDestination) = False Then Fso.CreateFolder(DosDestination)
                    Fso.MoveFile DosFichiers & Fichier.Name, _
                             DosDestination & Left(Fichier.Name, 2) & "\" & Fichier.Name
                End If
 
        Next Fichier
 
End Sub

Bon courage,
 

KROMS

XLDnaute Nouveau
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Bonsoir et merci de cette réponse aussi rapide ! ! !

J'ai eu un message "permission refusée"; c'est la première fois que je vois ça.
Comment passer outre ?
 

KROMS

XLDnaute Nouveau
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Bonsoir, l'erreur commence dès que je lance la macro.
Peut-être est-ce lié, aux restrictions d'usage de l'informatique chez nous, ou à une légère modif de code :

Sub Deplacer()

'A adapter
DeplacerFichiers ThisWorkbook.Path & "\", ThisWorkbook.Path & "\Lot"

End Sub

Private Sub DeplacerFichiers(DosFichiers As String, _
DosDestination As String)

Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim i As Long
Dim j As Integer

'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

'vérifie que le dossier d'origine existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
'If Fso.FolderExists(DosDestination) = False Then mkdir(DosDestination)

'récupère la collection des fichiers
'dans le dossier d'origine
Set Dos = Fso.GetFolder(DosFichiers)

'parcour la collection
'si le dossier n'existe pas, le dossier est créé et le fichier est déplacé
For Each Fichier In Dos.Files
i = i + 1
If i > 10 Then DosDestination = DosDestination & j + 1
If Fso.FolderExists(DosDestination) = False Then Fso.CreateFolder (DosDestination)
Fso.MoveFile DosFichiers & Fichier.Name, _
DosDestination & Left(Fichier.Name, 2) & "\" & Fichier.Name

Next Fichier

End Sub
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Excuse moi d'insister, mais que veux-tu dire dès le lancement de la macro ?
Autre chose: tu es en environnement réso. As-tu essayé de créer un répertoire "à la main" pour vérifier que tu as les droits ? Idem avec le déplacement d'un fichier ?

Cdlt,
 

KROMS

XLDnaute Nouveau
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

bonsoir,

j'ai vérifié avec mon administrateur des réseaux et des postes informatiques, qui a essayé de la lancer lui aussi, sans succès.
je suis également administrateur de mon PC

on a une Permission refusée (erreur 70)
"Vous avez tenté d'écrire sur un disque protégé en écriture ou d'accéder à un fichier verrouillé. Causes et solutions de cette erreur :

Vous avez tenté d'ouvrir un fichier protégé en écriture pour un accès séquentiel Output ou Append.
Ouvrez le fichier pour un accès Input ou changez l'attribut de protection en écriture du fichier.

Vous avez tenté d'ouvrir un fichier sur un disque protégé en écriture pour un accès séquentiel Output ou Append.
Retirez la protection en écriture du disque ou ouvrez le fichier pour un accès Input.

etc"[/I
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Re,

Je regarderai demain, car je dois m'éclipser. Néanmoins, j'insiste encore: sur quelle ligne EXACTEMENT as-tu l'erreur ? Le code peux se dérouler correctement et bloquer juste sur une ligne (il peut y avoir une bête erreur de syntaxe par exemple).
Autre petit conseil pour essayer de trouver l'erreur: Dans le VBE, afficher la fenêtre Variables Locales puis lancer le programme en mode pas à pas: consulter les variables au fur et à mesure pour vérifier qu'il n'y a pas de problème.

J'essaierai de faire un test sur des fichiers/répertoires bidons pour voir s'il n'y a pas un problème dans le code.

En attendant, bonne soirée et bon courage,
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Salut Kroms,

Petite intuition sans avoir encore testé:
Comme tu récupères le chemin à partir de ton fichier, cela signifie qu'il est situé dans le même répertoire que les fichiers à déplacer. Or,
comme celui-ci est ouvert pour pouvoir s’exécuter, il est donc impossible de le déplacer.

A vérifier.
Bon courage,
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Re,

Ci-joint solution mieux adaptée. Reste juste un petit truc à trouver pour la bascule de tout les xMilliers de fichiers, car pour l'instant dès qu'on passe (10 ici) un nouveau répertoire est créé à chaque fois. J'ai mis des commentaires dans le code aux endroits que j'ai modifiés.

VB:
Sub Deplacer()

'A adapter
DeplacerFichiers "D:\Temp\", "D:\Lot"   '#1 A noter l'absence de slash

End Sub

Private Sub DeplacerFichiers(DosFichiers As String, _
DosDestinationName As String)     '#2 Changement du nom de variable

Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim i As Long
Dim j As Integer

'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

'vérifie que le dossier d'origine existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
'If Fso.FolderExists(DosDestination) = False Then mkdir(DosDestination)

'récupère la collection des fichiers
'dans le dossier d'origine
Set Dos = Fso.GetFolder(DosFichiers)

'parcour la collection
'si le dossier n'existe pas, le dossier est créé et le fichier est déplacé
For Each Fichier In Dos.Files
i = i + 1
'#3 Modification du traitement et correction d'une erreur d'adaptation du code d'origne.
If i > 10 Then j = j + 1: DosDestination = DosDestinationName & j + 1
If Fso.FolderExists(DosDestination & "\") = False Then Fso.CreateFolder (DosDestination & "\")
    Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name
Next Fichier

End Sub

Bon courage
 

KROMS

XLDnaute Nouveau
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Bonjour docteur et merci de cette réponse !

J'ai cependant un petit doute : chaque dossier créé ne contient qu'un seul fichier au lieu de 10 ou ... 500

Par ailleurs, tant qu'à écrire ma lettre au Père Noël, j'avoue que j'aimerais bien que dans chaque répertoire soit intégré un sous-repertoire toujours nommé "done", et un fichier excel bien précis nommé +++.xlsm

J'en demande beaucoup, c'est vrai mais c'est bientôt Noël, non ?

1000 Mercis et bravos !
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Re,

Le père Noël est très pris aujourd'hui, et je ne sais pas si j'aurai le temps de me pencher sur ces 2 points. Pour le problème des répertoires c'est que je disais, il faut que je trouve l'astuce pour qu'à partir de 10 ou 500, il n'y a pas 1 répertoire créé à chaque fois.
Pour le répertoire "done" c'est pas bien compliqué, pour le fichier xlsm il faut que tu me donnes quelques précisions complémentaires car ce n'est pas très clair.

Cdlt,
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Re,

Le père Noël est très pris aujourd'hui, et je ne sais pas si j'aurai le temps de me pencher sur ces 2 points. Pour le problème des répertoires c'est que je disais, il faut que je trouve l'astuce pour qu'à partir de 10 ou 500, il n'y a pas 1 répertoire créé à chaque fois.
Pour le répertoire "done" c'est pas bien compliqué, pour le fichier xlsm il faut que tu me donnes quelques précisions complémentaires car ce n'est pas très clair.

Cdlt,
 

Jam

XLDnaute Accro
Re : Déplacer des fichiers en masse dans des répertoires avec une boucle ?

Re,

Aller, un dernier effort qui solutionne le problème des répertoires avec des orphelins:
- Ajout d'une variable dans la fonction qui permet de choisir le "pas" (tout les 10, 200, 10000...)
- Modification du code qui permet de générer le bon nombre de répertoire

VB:
Sub Deplacer()

'A adapter
DeplacerFichiers "D:\Temp\", "D:\Lot", 20

End Sub

Private Sub DeplacerFichiers(DosFichiers As String, _
DosDestinationName As String, iParPasDe As Integer)

Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim i As Long
Dim j As Integer
Dim DosDestination As String

'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

'vérifie que le dossier d'origine existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
'If Fso.FolderExists(DosDestination) = False Then mkdir(DosDestination)

'récupère la collection des fichiers
'dans le dossier d'origine
Set Dos = Fso.GetFolder(DosFichiers)

'parcour la collection
'si le dossier n'existe pas, le dossier est créé et le fichier est déplacé
'# Initialisation des variables
DosDestination = DosDestinationName & 1
j = 0
For Each Fichier In Dos.Files
    i = i + 1
    If i - (j * iParPasDe) > iParPasDe Then j = j + 1: DosDestination = DosDestinationName & j + 1
    If Fso.FolderExists(DosDestination & "\") = False Then Fso.CreateFolder (DosDestination & "\")
        Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name
Next Fichier

End Sub

Bon courage,
 

Discussions similaires

Réponses
19
Affichages
2 K

Statistiques des forums

Discussions
311 725
Messages
2 081 948
Membres
101 849
dernier inscrit
florentMIG