Classement plusieurs fichiers dans differents répertoire contenant le meme nom [Résolu]

[tepuy]

Bonjour, je suis débutant en vba et mon pb est celui ci .
Je cherche a classer( déplacer ) des fichiers contenus dans un repertoire source et les ranger dans differents répertoire dont la syntaxe de leur nom contient une partie du nom du fichier.Dans le repertoire source j'ai 1200 fichiers nommés differement
Exemple:
Dans C:\Source
j'ai Fiche_technique_AAA,xls
manuel_utilisateur_AAA.doc
Fiche_technique_BBB.xls
manuel_utilisateur_BBB.doc
photos_BBB.jpg
Fiche_technique_CCC.xls etc...
et je cherche a deplacer tous ces fichiers quelque soit leur extension vers le répertoire contenant une partie de leur nom.
Fiche_technique_AAA,xls
manuel_utilisateur_AAA.doc
devra etre classé dans le repertoire nommé A soit dans c:\Mes documents\A
Fiche_technique_BBB.xls
manuel_utilisateur_BBB.doc
photos_BBB.jpg
devra etre classé dans le repertoire nommé B soit dans c:\Mes documents\B etc...

J'ai cherché sur le net et je pensais passer par une commande Filetsystem.MoveFile.
Pouvez vous m'aider .Merci

[ZebreLoup]

As-tu regardé ce cours ?

[tepuy]

Je vais essayer ce code

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
Sub Explorer(p_strFichier As String, p_strCheminDepart As String, Optional p_oFld As Scripting.Folder)
On Error GoTo err
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFl As File
    If p_oFld Is Nothing Then
        'Instanciation du FSO
        Set oFSO = New Scripting.FileSystemObject
        'Accède au répertoire du départ de recherche
        Set p_oFld = oFSO.GetFolder(p_strCheminDepart)
    End If
    Set oFl = p_oFld.Files(p_strFichier)
    MsgBox oFl.Path
 
SubDir:
'Explore les sous-dossiers
    For Each oFld In p_oFld.SubFolders
        Explorer p_strFichier, p_strCheminDepart, oFld
        DoEvents
    Next oFld
 
fin:
    Exit Sub
err:
    Select Case err.Number
        Case 53: Resume SubDir
        Case Else:
            MsgBox "Erreur inconnue"
            Resume fin
    End Select
 
'deplace les fichiers possedant n'importe quelle extension dans un repertoire dont le nom correspond au nom de fichier déplacé
' ex: je deplace le fichier D:\A\fiche_technique_1.doc vers D:\B\1\
'ex: je deplace le fichier D:\A\manuel_utilisateur_1.doc vers D:\B\1\
'ex: je deplace le fichier D:\A\fiche_technique_2.doc vers D:\B\2\
' ⋅.⋅ correspond a etoile .point etoile et ⋅\ a étoile point slash
oFSO.MoveFile "D:\A\⋅.⋅", "D:\B\⋅\ "
 
End Sub

Les noms de fichiers du repertoire source commenceront souvent par manuel_utilisateur_le nom de l'appareil ou fiche_technique_le nom de l'appareil,et devront se classer dans les differents repertoires nommé par "le nom de l'appareil"

Pouvez vous me dire si je suis dans la bonne direction pour resoudre ce pb.
Merci

[Theze]

Bonjour,

Une solution, tes fichiers sont tous dans le même dossiers (enfin, je pense), tu veux qu'ils soient regroupés par le nom de l'appareil (sans prise en compte de l'extension) dans des dossiers comportant une partie du nom de l'appareil. Dans la proc ci-dessous, les dossiers sont créés avec les trois dernières lettres du nom des fichiers (il faut adapter le code pour plus de lettres), exemple :
Le dossier "destination" est C:\Source\
comme les sous-dossiers n'existent pas, le premier dossier créé sera le dossier AAA et dans ce dossier seront déplacés les fichiers :
Fiche_technique_AAA,xls
manuel_utilisateur_AAA.doc
puis un autre dossier sera créé avec le nom BBB où seront ensuite déplacés les fichiers suivants :
Fiche_technique_BBB.xls
manuel_utilisateur_BBB.doc
et ainsi de suite...
Lance la proc "Deplacer" mais fait un test avec les copies de quelques fichiers dans un dossier test pour voir le résultat. Tu crées un dossier "Test" dans C:\ où tu copie quelques fichiers pour voir comment sont créés les dossiers et déplacés les fichiers et si ceci te convient, tu lance la proc avec comme dossier de destination "C:\Source\"

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
 
Sub Deplacer()
 
    DeplacerFichiers "C:\Test\"
 
End Sub
 
Sub DeplacerFichiers(DosDestination As String)
 
    Dim Fso As Object
    Dim Dossier As Object
    Dim Fichier As Object
    Dim NouvDos As Object
 
    'crée l'objet
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    'si le dossier cible n'existe pas, fin
    If Fso.FolderExists(DosDestination) = False Then Exit Sub
 
    'défini le dossier où effectuer la recherche des fichiers et la création des dossiers
    Set Dossier = Fso.GetFolder(DosDestination)
 
        '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 & "\" & UCase(Mid(Fichier.Name, InStrRev(Fichier.Name, ".") - 3, 3))) = True Then
 
                Fso.MoveFile Fichier, Dossier & "\" & UCase(Mid(Fichier.Name, InStrRev(Fichier.Name, ".") - 3, 3)) & "\" & Fichier.Name
 
            Else
 
                Set NouvDos = Fso.CreateFolder(Dossier & "\" & UCase(Mid(Fichier.Name, InStrRev(Fichier.Name, ".") - 3, 3)))
 
                Fso.MoveFile Fichier, NouvDos & "\" & Fichier.Name
 
            End If
 
        Next Fichier
 
End Sub

Hervé.

[tepuy]

Fabuleux

Bonjour et merci theze
la macro range bien les fichiers dans les dossiers ou crée les dossier absent.
En augmentant la valeur 3, 3 dans cette partie de code

Code :

(Mid(Fichier.Name, InStrRev(Fichier.Name, ".") - 3, 3)))

j'ai pu agrandir le nombre de lettres dans les dossiers crées.
Est ce que je me trompe ou pas ? Quand Tu ecris Mid dans le code tu passes bien par une fonction STXT()?
Je m'explique la les dossiers sont crées a partir du suffixe du nom de fichiers ( a partir de la droite) . s dossiers sont crées a partir du suffixe du nom de fichiers ( a partir de la droite) .
Je souhaite que les dossiers soient crées a partir du préfixe du nom de fichier ( a partir de la gauche) ou a partir du deuxieme mot du nom de fichiers quelque soit le nombre de caractère ( dans mon cas cela sera soit "fiche", soit "technique").
Je pense qu'il faudra dans le premier cas lister la chaine de caractère avant le premier underscore .
Et dans le deuxieme cas chercher le premier underscore, chercher le deuxieme underscore et lister le nombre de caractère compris entre les deux.

Ceci afin de pouvoir définir une syntaxe particulière a

Suis je dans la bonne voie

[Theze]

Bonjour,

Désolé du retard.

Effectivement, la fonction Mid est identique à la fonction Excel STXT.

Code :

InStrRev(Fichier, ".")

retourne la position du point en commençant la recherche par la droite.

Code :

Mid(Fichier.Name, InStrRev(Fichier.Name, ".") - 3, 3)

retourne les 3 lettres (argument Length = 3) situées à gauche de la position du point (argument Start = position du point -3).

Si tu veux trouver le mot "technique", utilise ceci (Instr recherche le premier tiret bas en partant de la gauche) :

Code :

Mid(Fichier.Name, InStr(Fichier.Name, "_") + 1, 9)

sinon, pour le mot "fiche" tout simplement :

Code :

Left(Fichier.Name, 5)

Hervé.

[tepuy]

Bonjour Un grand merci a toi thèze