Macro pour déplacer un fichier dans un dossier du même nom
Bonsoir,
Existe-t-il une macro pour déplacer des fichiers EXCEL dans un dossier qui porte le même nom que les fichiers EXCEL.
Les fichiers EXCEL se trouvent sur le bureau "C:\Users\tony1\OneDrive\Documents\" et se nomme 1311234, 1311345, 1311456, ...
Les dossiers se trouvent également dans "C:\Users\tony1\OneDrive\Documents\" et se nomme 1311234, 1311345, 1311456, ...
Je vous en remercie par avance pour vos retours.
Cordialement.
Bonjour,
Avec OneDrive, je ne sais pas si ça peut fonctionner mais a tester :
Tu mets ce code dans un nouveau fichier,
Il va lister les fichiers contenu dans ton emplacement de dossier,
Si un dossier a le même nom qu'un de tes fichiers, le fichier sera déplacé dans ce dossier.
Sub DeplacerTony()
'Déplacer un fichier dans un dossier qui porte son nom
Dim FSO, SourceDossier As Object
Dim Emp_dossier, Fichier, Nom_fichier, Ext_fichier, Chemin_Avant, Chemin_Apres As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Emp_dossier = "C:\Users\tony1\OneDrive\Documents\"
Set SourceDossier = FSO.GetFolder(Emp_dossier)
For Each Fichier In SourceDossier.Files
Nom_fichier = Split(Fichier.Name, ".")(0)
Ext_fichier = Split(Fichier.Name, ".")(1)
Chemin_Avant = Emp_dossier & Nom_fichier & "." & Ext_fichier
Chemin_Apres = Emp_dossier & Nom_fichier & "\" & Nom_fichier & "." & Ext_fichier
If Dir(Emp_dossier & Nom_fichier, vbDirectory) <> vbNullString Then
FSO.MoveFile Chemin_Avant, Chemin_Apres
End If
Next Fichier
End SubA+
Bonsoir,
merci beaucoup ça fonctionne !
J'ai juste une dernière question, si le fichier EXCEL se nomme "1311234" et le dossier "1311234 FAM", est-il possible de modifier la macro pour que si le dossier contient le nom du fichier EXCEL (1311234) il le classe automatiquement dans le dossier 1311234 FAM ?
Merci par avance.
Bonne soirée.
Bonjour,
Si tu as un dossier "1311234 FAM" et un dossier "1311234 AAA" le fichier sera déplacé dans la "AAA" (ordre alphabetique des dossiers).
J'utilise le nombre de caratere du fichier pour savoir si un dossier commence avec les mêmes caracteres que les carateres du fichier à classer si oui il deplace le fichier dans le premier dossier correspondant et passe au fichier suivant.
A tester :
Sub DeplacerTony2()
'Déplacer un fichier dans un dossier qui porte son nom (ou qui commence comme le nom de son fichier)
Dim FSO, SourceDossier As Object
Dim Emp_dossier, FichierClass, Nom_fichier, Ext_fichier, Chemin_Avant, Chemin_Apres As String
Dim DossierClass As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Emp_dossier = "C:\Users\tony1\OneDrive\Documents\"
Set SourceDossier = FSO.GetFolder(Emp_dossier)
For Each FichierClass In SourceDossier.Files
Nom_fichier = Split(FichierClass.Name, ".")(0)
Ext_fichier = Split(FichierClass.Name, ".")(1)
Chemin_Avant = Emp_dossier & Nom_fichier & "." & Ext_fichier
For Each DossierClass In SourceDossier.SubFolders
If Left(DossierClass.Name, Len(Nom_fichier)) = Nom_fichier Then
Chemin_Apres = Emp_dossier & DossierClass.Name & "\" & Nom_fichier & "." & Ext_fichier
If Dir(Emp_dossier & DossierClass.Name, vbDirectory) <> vbNullString Then
FSO.MoveFile Chemin_Avant, Chemin_Apres
End If
Exit For
End If
Next DossierClass
Next FichierClass
End SubA+
Bonsoir,
Parfait, ça fonctionne également, merci beaucoup.
Bonne soirée.
Bonsoir,
pour compléter la macro, est-il possible de spécifier sur le fichier excel de la macro la destination des fichiers à déplacer ?
Par exemple, pour éviter de modifier la destination des fichiers dans le script de la macro, je voudrais si possible rentrer sur le fichier excel la destination des fichiers.
Soit en le saisissant soit avec un bouton qui permet de parcourir les dossiers de l'ordinateur.
Le fichier est en PJ.
Merci par avance pour vos retours.
Cordialement.
Bonsoir,
Oui, si tu souhaites indiquer en B5 le dossier,
Il faut changer la ligne "Emp_dossier" dans la macro en :
Emp_dossier = Range("B5").ValueSi tu veux ouvrir une fenetre explorateur pour y choisir ton dossier "destination", tu peux utiliser :
Sub DeplacerTony3()
'Déplacer un fichier dans un dossier qui porte son nom (ou qui commence comme le nom de son fichier)
Dim FSO, SourceDossier As Object
Dim Emp_dossier, FichierClass, Nom_fichier, Ext_fichier, Chemin_Avant, Chemin_Apres As String
Dim DossierClass As Variant
Dim RechDos As Office.FileDialog
Set FSO = CreateObject("Scripting.FileSystemObject")
Set RechDos = Application.FileDialog(msoFileDialogFolderPicker)
If RechDos.Show() Then Emp_dossier = RechDos.SelectedItems(1) & "\"
Set SourceDossier = FSO.GetFolder(Emp_dossier)
For Each FichierClass In SourceDossier.Files
Nom_fichier = Split(FichierClass.Name, ".")(0)
Ext_fichier = Split(FichierClass.Name, ".")(1)
Chemin_Avant = Emp_dossier & Nom_fichier & "." & Ext_fichier
For Each DossierClass In SourceDossier.SubFolders
If Left(DossierClass.Name, Len(Nom_fichier)) = Nom_fichier Then
Chemin_Apres = Emp_dossier & DossierClass.Name & "\" & Nom_fichier & "." & Ext_fichier
If Dir(Emp_dossier & DossierClass.Name, vbDirectory) <> vbNullString Then
FSO.MoveFile Chemin_Avant, Chemin_Apres
End If
Exit For
End If
Next DossierClass
Next FichierClass
End SubA+
Bonsoir,
Cela ne fonctionne pas si j'indique le chemin en B5, la macro se lance mais elle ne déplace pas les fichiers.
Par contre pour ouvrir une fenêtre explorateur pour y choisir mon dossier "destination", cela fonctionne.
Merci beaucoup pour ton aide, c'est parfait.
Cordialement.
Bonsoir,
Juste pour info, si en B5 la macro se lance mais ne déplace pas les fichiers,
Je pense que tu as oublié un "\" a la fin du chemin.
Pour etre sur que ça fonctionne meme si on oublie ce "\", on peut rajouter une ligne comme :
Emp_dossier = Range("B5").Value
If Right(Emp_dossier, 1) <> "\" Then Emp_dossier = Emp_dossier & "\"A+
Bonsoir,
effectivement j'avais oublié le "\" à la fin du chemin.
Merci pour le complément de la macro.
Bonne soirée.
Cordialement.
Bonsoir,
désolé de te déranger à nouveau.
Je voulais savoir si c'était possible de modifier le critère pour déplacer le fichier.
Par exemple le dossier commencera toujours par une série de 9 chiffres, exemple "130008733 + TEXTE".
Par contre les fichiers à déplacer auront également la même série de 9 chiffres mais ils peuvent être au début ou à la fin du nom, exemple "130008733" ou "130008733 + TEXTE" ou "TEXTE + 130008733".
Pour résumé, si le fichier à déplacer contient les 9 premiers chiffres du dossier alors il faut le déplacer dans ce dossier.
Si c'est trop compliqué ce n'est pas grave, tu m'as déjà beaucoup aidé.
Merci.
Bonne soirée.
Bonsoir,
Les caracteres "ABCDEFGHIJKLMNOPQRSTUVWXYZ -_abcdefghijklmnopqrstuvwxyz" vont etre supprimé du nom de fichier
Pour creer la variable "Chiffre_Nom_fichier" qui va me servir a voir si elle est contenu dans le nom d'un dossier
Si correspondance, déplacement du fichier dans le dossier (le nom du fichier ne change pas)
(vu que je supprime les espaces si le dossier se nomme "bla1 5bla" il ne va pas deplacer le fichier car "15" <> "1 5")
Sub DeplacerTony4()
'Déplacer un fichier dans un dossier qui contient les memes chiffres
Const SuppChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ -_abcdefghijklmnopqrstuvwxyz"
Dim Chars As Integer
Dim SuiteChars As String * 1
Dim Chiffre_Nom_fichier As String
Dim FSO, SourceDossier As Object
Dim Emp_dossier, FichierClass, Nom_fichier, Ext_fichier, Chemin_Avant, Chemin_Apres As String
Dim DossierClass As Variant
Dim RechDos As Office.FileDialog
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set RechDos = Application.FileDialog(msoFileDialogFolderPicker)
If RechDos.Show() Then Emp_dossier = RechDos.SelectedItems(1) & "\"
Set SourceDossier = FSO.GetFolder(Emp_dossier)
For Each FichierClass In SourceDossier.Files
Nom_fichier = Split(FichierClass.Name, ".")(0)
Ext_fichier = Split(FichierClass.Name, ".")(1)
'Supprime les characteres sauf les chiffres du fichier
Chiffre_Nom_fichier = Nom_fichier
For Chars = 1 To Len(SuppChars)
Chiffre_Nom_fichier = Replace(Chiffre_Nom_fichier, Mid(SuppChars, Chars, 1), "")
Next Chars
Chemin_Avant = Emp_dossier & Nom_fichier & "." & Ext_fichier
For Each DossierClass In SourceDossier.SubFolders
'Si le dossier contient les chiffres du fichier on deplace le fichier
If Left(DossierClass.Name, Len(Nom_fichier)) Like "*" & Chiffre_Nom_fichier & "*" Then
Chemin_Apres = Emp_dossier & DossierClass.Name & "\" & Nom_fichier & "." & Ext_fichier
If Dir(Emp_dossier & DossierClass.Name, vbDirectory) <> vbNullString Then
FSO.MoveFile Chemin_Avant, Chemin_Apres
End If
Exit For
End If
Next DossierClass
Next FichierClass
Application.ScreenUpdating = True
End SubA+
Bonsoir,
merci pour la macro, il n'a juste pas déplacé le fichier "Constat d'anomalies 130008733_p1.pdf" dans le dossier "130008733 + TEXTE".
D'après ton explication c'est normal vu qu'il y a un autre chiffre dans le nom du fichier "Constat d'anomalies 130008733_p1.pdf".
Merci.
C'est bien ça.
Si il n'y a pas de norme pour le nom des fichiers difficile d'automatiser quelque chose.
Est-ce qu' il y a toujours 9 chiffres séparé d'un tiré du bas "_" (pas d'autres caractères) par rapport au texte dans ton nom de fichier ? Que le texte soit avant ou après.
Bonsoir,
Le fichier "Constat d'anomalies 130008733_p1.pdf" est généré par une autre macro, je vais essayer de voir si ce n'est pas possible de modifier le nom à la sortie du fichier pour éviter de modifier ta macro.
Merci.
Passe une bonne soirée.
Bonsoir,
Tu peux tester ça avant de modifier l'autre macro.
Ici, peu importe le nom du fichier (si il y a des chiffres mélangé a du texte ou autre) je transforme tout les espaces en "Tiret Bas" ensuite je cherche les caracteres "_" et si il y a 9 chiffres dérriere (variable "Cherche_Chiffre_Nom_fichier") et qu'un dossier a ce code, je déplace le fichier.
Sub DeplacerTony5()
'Déplacer un fichier dans un dossier qui contient les memes 9 chiffres
Dim Chiffre_Nom_fichier As String
Dim Cherche_Chiffre_Nom_fichier As Variant
Dim FSO, SourceDossier As Object
Dim Emp_dossier, FichierClass, Nom_fichier, Ext_fichier, Chemin_Avant, Chemin_Apres As String
Dim DossierClass As Variant
Dim RechDos As Office.FileDialog
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set RechDos = Application.FileDialog(msoFileDialogFolderPicker)
If RechDos.Show() Then Emp_dossier = RechDos.SelectedItems(1) & "\"
Set SourceDossier = FSO.GetFolder(Emp_dossier)
For Each FichierClass In SourceDossier.Files
Nom_fichier = Split(FichierClass.Name, ".")(0)
Ext_fichier = Split(FichierClass.Name, ".")(1)
'Transforme les espace en "Tiret Bas" et trouves les 9 caratere suivant
Chiffre_Nom_fichier = Replace(Nom_fichier, " ", "_")
For PositionTiretBas = 1 To Len(Chiffre_Nom_fichier)
Cherche_Chiffre_Nom_fichier = Mid(Chiffre_Nom_fichier, InStr(PositionTiretBas, Chiffre_Nom_fichier, "_") + 1, 9)
'Si c'est un nombre de 9 chiffre, on a trouvé le code du fichier a classer, on sort de la boucle
If IsNumeric(Cherche_Chiffre_Nom_fichier) Then Exit For
Next PositionTiretBas
Chemin_Avant = Emp_dossier & Nom_fichier & "." & Ext_fichier
For Each DossierClass In SourceDossier.SubFolders
'Si le dossier contient les chiffres du fichier on deplace le fichier
If Left(DossierClass.Name, Len(Nom_fichier)) Like "*" & Cherche_Chiffre_Nom_fichier & "*" Then
Chemin_Apres = Emp_dossier & DossierClass.Name & "\" & Nom_fichier & "." & Ext_fichier
If Dir(Emp_dossier & DossierClass.Name, vbDirectory) <> vbNullString Then
FSO.MoveFile Chemin_Avant, Chemin_Apres
End If
Exit For
End If
Next DossierClass
Next FichierClass
Application.ScreenUpdating = True
End SubA+
Bonjour,
c'est parfait, merci beaucoup, tous les fichiers se sont bien classés.
Passe une bonne journée.
Tony