Creation dossier et copie fichiers

[JRONDIER]

Bonsoir à tous,

Je débute en macro Excel et VBA et j'aurais besoin d'un petit coup de main. Je vous décris ce que je souhaite obtenir.

A l'heure actuelle, j'ai une arborescence de dossiers (environ 1000) dont le nom est une désignation d'un site.

Cette arborescence doit être modifiée pour ranger les dossiers suivant le département du site et renommer par son code.

J'ai donc un fichier excel qui pour chaque dossier existant indique le département et le code.

Je souhaite donc faire une macro qui créé tous les dossiers avec le code et qui copie les fichiers contenues dans le dossier d'origine (désignation) vers celui qui a été créé.

J'ai vu qu'il existait la fonction mkdir, que l'on peut faire des boucles.

Mais j'ai du mal à voir comment imbriquer tout cela pour atteindre mon objectif.

Merci d'avance

 

[Angelista]

Re : Creation dossier et copie fichiers

Bonjour JRONDIER,

As tu un fichier exemple afin de travailler dessus ?
Merci.

Angelista.

 

[JRONDIER]

Re : Creation dossier et copie fichiers

Bonsoir

tu trouveras en pieces jointes un fichier exemple.

colonne A : nom du site et donc nom du dossier actuel
colonne B : département du site futur dossier niveau 1
colonne C : code du site futur nom du dossier niveau 2

voila

 

[Angelista]

Re : Creation dossier et copie fichiers

Bonsoir,

Si j'ai bien tout compris, tu voudrais donc que la macro crée les dossiers et déplace des fichiers excel déjà existant à l'intérieur ?

Cdlt,

Angeslita.

 

[JRONDIER]

Re : Creation dossier et copie fichiers

Oui je voudrais que la macro créé les dossiers avec comme nom la colonne C dans le bon dossier de département colonne B et copie tous les fichiers contenus dans le dossier avec comme nom la colonne A dans le dosseir créé.

Le fichier excel ne sert que de base de données.

 

[Angelista]

Re : Creation dossier et copie fichiers

Bonsoir Jrondier,

J'ai pas pratiqué encore la création de dossier et déplacement de fichier excel via une macro,donc je ne sais pas si cela est faisable.

Angelista.

 

[tototiti2008]

Re : Creation dossier et copie fichiers

Bonsoir à tous,

un essai

Sub Transfert_dossiers()
Dim CheminSource As String, CheminDest As String 'Emplacements des dossiers source et destination
Dim DossSource As String, DossDest1 As String, DossDest2 As String, BoolErr As Boolean
Dim i As Long, FSO As Object, Fl As Object
    CheminSource = "C:\" 'A adapter : chemin des dossiers sources
    CheminDest = "C:\" 'A adapter : chemin des dossiers destination
    Set FSO = CreateObject("Scripting.FilesystemObject")
    With ThisWorkbook.Worksheets("Feuil1") 'Feuille contenant les données pour le transfert
    For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row 'Pour chaque ligne de la liste
            BoolErr = False
            DossSource = .Range("A" & i).Value 'On note le nom des dossiers de la ligne pour le traitement
            DossDest1 = .Range("B" & i).Value
            DossDest2 = .Range("C" & i).Value
            On Error GoTo ErrDepl
            If FSO.folderexists(CheminSource & DossSource) Then 'On vérifie l'existence du dossier source
                If Not FSO.folderexists(CheminDest & DossDest1) Then 'On crée le 1er dossier de destination
                    FSO.createfolder CheminDest & DossDest1
                End If
                If Not FSO.folderexists(CheminDest & DossDest1 &  "\" & DossDest2) Then 'On crée le second dossier de destination
                    FSO.createfolder CheminDest & DossDest1 & "\" & DossDest2
                End If
                For Each Fl In FSO.getfolder(CheminSource & DossSource).Files 'On déplace tous les fichiers
                    FSO.movefile CheminSource & DossSource & "\"  & Fl.Name, CheminDest & DossDest1 & "\" & DossDest2  & "\"
                Next
            Else
                .Range("D" & i).Value = "Dossier source non trouvé" 'Gestion erreur dossier source inexistant
            End If
            On Error GoTo 0
FinDepl:
            If BoolErr Then .Range("D" & i).Value = "Erreur lors de  la création de dossier ou du déplacement des fichiers" 'Gestion erreur  dans la création des dossiers ou le déplacement des fichiers
        Next i
    End With
    Set Fl = Nothing
    Set FSO = Nothing
    Exit Sub
ErrDepl:
    BoolErr = True
    Resume FinDepl
End Sub

Edit : ATTENTION, ça déplace les fichiers, ça ne les copie pas, je n'ai pas bien compris au bout s'il s'agit d'un déplacement ou d'une copie !!!

 

[tototiti2008]

Re : Creation dossier et copie fichiers

Re,

une version pour la copie