Déplacer fichier dans un dossier en fonction du nom

Version imprimable

04/03/2011, 14h44
asengs

Déplacer fichier dans un dossier en fonction du nom

Bonjour,

je souhaiterais trouver une macro qui me permette de déplacer des fichiers dans un répertoire, en fonction du nom du fichier et du nom du répertoire.

Je m'explique!
j'ai des fichiers qui vont se nommer de la façon suivante (les 2 premiers caractères étant le département)
01-test.xls
01-test1.xls
94-test.xls
95-xls

et j'aimerais que les fichiers soient déplacés dans le dossier de leur département
01-test.xls -> dans le dossier '01'
01-test1.xls -> dans le dossier '01'
94-test.xls-> dans le dossier '94'
95-xls-> dans le dossier '95'

Merci de votre aide

heuh!...

bonjour
voila l'exemple que je te propose

cousu sur mesure
il teste si le dossier existe si il existe il enregistre le fichier dedans
si le dossier n'existe pas il le crée et enregistre le fichier dedans

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub enregistrement()
  Dim chaine() As String
   chaine = Split(ActiveWorkbook.Name, ".")
 
 
   NomDossier = chaine(0)  'on recupere le nom du fichier
 MsgBox "le nom de dossier sera " & NomDossier
 
    If DossierExiste("C:\" & NomDossier) = False Then
    MkDir "C:\" & NomDossier: GoTo suite
Else
suite:
ActiveWorkbook.SaveAs Filename:="c:\" & NomDossier & "\" & ActiveWorkbook.Name, _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
End If
End Sub
 
 
Function DossierExiste(NomDossier As String) As Boolean
    DossierExiste = Dir(NomDossier, vbSystem + vbDirectory + vbHidden) <> ""
End Function

04/03/2011, 16h51
asengs

Merci de ton aide...

En fait, je voudrais une macro qui aille lire un dossier dans lequel se trouve tous mes fichiers Excels et qui prend les 2 premiers caractères du nom des fichiers excel et si ces 2 premiers caracteres correspondent aux deux premiers caractères d'un dossier (qui se trouve sous un autre chemin ou pas) alors il copie le fichier excel dans ce dossier.

Tous les dossiers seront crées (1 par département). J'ai besoin d'automatiser ca car j'ai 12.000 fichiers et il y a 106 départements.

Bonsoir,

Test ce qui suit. Les dossiers des départements devant recevoir les fichiers doivent tous être dans un même dossier, le dossier de destination :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 
Sub Deplacer()
 
    'Attention, les dossiers des départements doivent tous être
    'dans le même dossier, le dossier de destination. Adapter
    DeplacerFichiers "D:\DossierOrigine\", "D:\DossierDestination\"
 
End Sub
 
Private Sub DeplacerFichiers(DosFichiers As String, _
                             DosDestination As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim Fichier As Object
 
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    '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)
 
        'parcour la collection en recherchant dans le dossier de destination
        'le dossier correspondant au numéro du département du fichier
        'si le dossier existe, le fichier est déplacé
        For Each Fichier In Dos.Files
 
            If Fso.FolderExists(DosDestination & Left(Fichier.Name, 2)) = True Then
                Fso.MoveFile DosFichiers & Fichier.Name, _
                             DosDestination & Left(Fichier.Name, 2) & "\" & Fichier.Name
            End If
 
        Next Fichier
 
End Sub

Hervé.

Oups,

J'ai oublié de gérer les n° de départements, 2 ou 3 chiffres, donc je reposte :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
Private Sub DeplacerFichiers(DosFichiers As String, _
                             DosDestination As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim Fichier As Object
    Dim I As Integer
 
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    '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)
 
        'parcour la collection en recherchant dans le dossier de destination
        'le dossier correspondant au numéro du département du fichier
        'si le dossier existe, le fichier est déplacé
        For Each Fichier In Dos.Files
 
            'département à 2 ou 3 chiffres
            If InStr("0123456789", Mid(Fichier.Name, 3, 1)) <> 0 Then
 
                I = 3
 
            Else
 
                I = 2
 
            End If
 
            'départements à 2 chiffres
            If Fso.FolderExists(DosDestination & Left(Fichier.Name, I)) = True Then
 
                Fso.MoveFile DosFichiers & Fichier.Name, _
                             DosDestination & Left(Fichier.Name, I) & "\" & Fichier.Name
 
            End If
 
        Next Fichier
 
End Sub

07/03/2011, 10h39
asengs

Merci Theze, c'est parfait :ccool:, c'est exactement ça qu'il me fallait

J'ai une autre petite question, sans vouloir trop abusé de ton temps,

Une fois les fichiers placés dans leur dossier par département, j'ai de nouveaux un dispatch à faire des fichiers dans des sous dossiers (nom d'une personne, 1 à 8 caracteres) de chaque dossier par déparatement,

Je pensais adapter ta macro mais je ne sais pas comment en fait, car il faut que je puisse lire chaque dossier par dept (et les fichiers contenus) et les placer dans le sous dossier de la personne concerné, et cela pour chaque departement

exemple

01-Dupont.xls ->01->Dupont
01-Jean.xls ->01->Jean
01-Jean_2.xls ->01->Jean
68-Eric.xls->68->Eric

Merci d'avance pour ton aide
07/03/2011, 11h48
patricktoulon

re

bonjour

il ne faudrais pas oublier que personne n'est ici pour faire le travail d'un autre

donc si tu veux que l'on t'aide commence dabord par écrire quelques lignes de codes et on t'aidera a le corriger
mais en aucun cas on fera le travail a ta place

au plaisir
07/03/2011, 12h14
asengs

Bonjour patricktoulon,

En effet jsuis d'accord avec toi, ce n'est pas ce que je demande qu'on fasse le travail à ma place, mais pour tout avouer je ne suis pas très calé en vb, j'ai réussi à faire quelques macros qui restaient très simples!

Et sur cette histoire de lire dans les dossier, etc, je coince, de plus il me manque les connaissances des instructions, etc...

Donc c'est pour cela que je demandais de l'aide car là je suis vraiment coincé!

Désolé si cela a été mal pris!!

Bonsoir,

Teste ce qui suit.
La proc parcour les dossiers (01, 02, 03, etc...) du dossier de destination et ensuite parcour la collection de fichiers de ces dossiers (fichiers qui ont été déplacés avec l'autre proc). Pour chaque fichier, si le dossier portant le nom du fichier existe alors le fichier est déplacé dedans sinon, le dossier est créé et le fichier est ensuite placé dedans. Dis moi si ça te va ?
Les fichiers doivent être nommés comme tu l'a indiqué "01-Jean.xls" avec un tiret du 6 :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
Sub ReDeplacer()
 
    ReDeplacerFichiers "D:\DossierDestination\"
 
End Sub
 
Sub ReDeplacerFichiers(DosDestination As String)
 
    Dim TblDossiers
    Dim Fso As Object
    Dim D As Object
    Dim Dos As Object
    Dim Dossier As Object
    Dim Fichier As Object
    Dim NouvDos As Object
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Fso.FolderExists(DosDestination) = False Then Exit Sub
 
    Set Dos = Fso.GetFolder(DosDestination)
 
    'parcour la collection de dossiers du dossier de destination
    For Each Dossier In Dos.SubFolders
 
        'parcour la collection de fichiers du dossier en cours
         For Each Fichier In Dossier.Files
 
            'si le dossier portant le nom du fichier existe, le fichier est déplacé dans ce dossier
            'sinon, le dossier est créé et le fichier est ensuite placé dedans
            If Fso.FolderExists(Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4)) = True Then
 
                Fso.MoveFile Fichier, _
                             Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4) & "\" & Fichier.Name
 
            Else
 
                Set NouvDos = Fso.CreateFolder(Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4))
 
                Fso.MoveFile Fichier, _
                             NouvDos & "\" & Fichier.Name
            End If
 
        Next Fichier
 
    Next Dossier
 
End Sub

Hervé.

Bonjour,

J'ai oublié de prendre en compte que les classeurs peuvent être des .xlsx ou autres au lieu de .xls, donc (j'ai viré 2 variables inutiles) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
 
Sub ReDeplacerFichiers(DosDestination As String)
 
    Dim Fso As Object
    Dim Dos As Object
    Dim Dossier As Object
    Dim Fichier As Object
    Dim NouvDos As Object
    Dim Pos1 As Integer
    Dim Pos2 As Integer
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Fso.FolderExists(DosDestination) = False Then Exit Sub
 
    Set Dos = Fso.GetFolder(DosDestination)
 
    'parcour la collection de dossiers du dossier de destination
    For Each Dossier In Dos.SubFolders
 
        'parcour la collection de fichiers du dossier en cours
         For Each Fichier In Dossier.Files
 
            Pos1 = InStrRev(Fichier.Name, "-")
            Pos2 = InStrRev(Fichier.Name, ".")
 
            'si le dossier portant le nom du fichier existe, le fichier est déplacé dans ce dossier
            'sinon, le dossier est créé et le fichier est ensuite placé dedans
            If Fso.FolderExists(Dossier & "\" & Mid(Fichier.Name, Pos1 + 1, Pos2 - Pos1 - 1)) = True Then
 
                Fso.MoveFile Fichier, _
                             Dossier & "\" & Mid(Fichier.Name, Pos1 + 1, Pos2 - Pos1 - 1) & "\" & Fichier.Name
 
            Else
 
                Set NouvDos = Fso.CreateFolder(Dossier & "\" & Mid(Fichier.Name, Pos1 + 1, Pos2 - Pos1 - 1))
 
                Fso.MoveFile Fichier, _
                             NouvDos & "\" & Fichier.Name
            End If
 
        Next Fichier
 
    Next Dossier
 
End Sub

Hervé.

08/03/2011, 09h08
asengs

Grand merci

Tout est dans le titre de mon message Merci encore Hervé!

Je pense que je vais pouvoir m'en sortir maintenant grâce à ton aide
08/03/2011, 16h50
Theze

Bonjour asengs,

Merci du retour. Si tu bute sur quelque chose, reviens on cherchera ensemble.

Hervé.