Création de répertoire via macro

[gigiati]

Bonsoir à tous,
Je cherche à créer une macro qui se déroule en deux phase (avec deux boutons par exemple) la première permet de créer un répertoire avec un nom qui se trouve dans la colonne X.

Pour ce faire le programme devra tester si X2 (X1 = le titre de la colone) n'existe pas déjà, si oui passer au suivant, si non le créer (C:\TEMP\X1\).

Ensuite (cela peut etre faite dans une autre macro) chercher un fichier à une adresse donnée Y (qui restera la meme tous le long de la macro ex: C:\TEMP\Fichiers_données) et la copier dans le répertoire du même nom.

Cela semble un peu tordu en relisant mais je vais faire un fichier excel pour exemple.

 

[jpb388]

Re : Création de répertoire via macro

Bonjour

Si tu n'as pas eu plus de réponse c'est, je crois, que tu n'as pas mis un petit merci. Qui j'en suis sûre n'est qu'un oubli

pourquoi faire 2 macros alors que une seule suffit.
Si tu en veux absolument 2 c'est évidemment possible
donne ton choix 1 ou 2
a+

 

[gigiati]

Re : Création de répertoire via macro

Bonjour, arf je suis désolé pour cet oublis (car oui c'est un oublis, car je mets assez souvent "Merci d'avance pour vos réponse" lors de mes question).

En fait je voulais deux macro pour mieux réussir à comprendre le fonctionnement de chaqu'un pour par la suite tenter par moi même de refaire une macro qui inclurait les deux.

Merci d'avance pour vos réponses

 

[Theze]

Re : Création de répertoire via macro

Bonjour,

Alors ici, avec une seule macro qui fait tout (attention, adapter les chemins) :

Private Sub DossiersFichiers()

    Dim Fso As Object
    Dim Dossier As String
    Dim DossierFichiers As String
    Dim I As Integer
    
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    'attention, les dossiers doivent exister sinon, erreur
    Dossier = "D:\TEMP\" 'dossier où seront créé les sous-dossiers
    DossierFichiers = "D:\Fichiers a copier\" 'dossier où se trouvent les fichiers à copier
    
    'parcour la plage et crée les dossiers inexistants et copie les fichiers correspondants
    'adapter le nom de la feuille
    With Worksheets("Feuil1")
    
        For I = 2 To .Cells(.Rows.Count, "X").End(xlUp).Row
            
            'création des dossiers
            If Fso.FolderExists(Dossier & .Cells(I, "X").Value) = False Then
            
                Fso.CreateFolder Dossier & .Cells(I, "X").Value
                
            End If
            
            'copie des fichiers
            If Fso.FileExists(DossierFichiers & .Cells(I, "X").Value & ".xls") = True Then
                
                Fso.CopyFile DossierFichiers & .Cells(I, "X").Value & ".xls", Dossier & .Cells(I, "X").Value & "\", True
                
            End If

        Next I
        
    End With
    
End Sub

Et ici, les proc sont séparées :

Private Sub CréerDossiers()

    Dim Fso As Object
    Dim Dossier As String
    Dim I As Integer
    
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    'attention, le dossier doit exister sinon, erreur
    Dossier = "D:\TEMP\" 'dossier où seront créé les sous-dossiers
    
    'parcour la plage et crée les dossiers inexistants et copie les fichiers correspondants
    'adapter le nom de la feuille
    With Worksheets("Feuil1")
    
        For I = 2 To .Cells(.Rows.Count, "X").End(xlUp).Row
            
            'création des dossiers
            If Fso.FolderExists(Dossier & .Cells(I, "X").Value) = False Then
            
                Fso.CreateFolder Dossier & .Cells(I, "X").Value
                
            End If
            
        Next I
        
    End With
    
End Sub

Private Sub CopierFichiers()

    Dim Fso As Object
    Dim Dossier As String
    Dim DossierFichiers As String
    Dim I As Integer
    
    'crée l'objet FileSystemObject
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    'attention, les dossiers doivent exister sinon, erreur
    Dossier = "D:\TEMP\" 'dossier où seront créé les sous-dossiers
    DossierFichiers = "D:\Fichiers a copier\" 'dossier où se trouvent les fichiers à copier
    
    'parcour la plage et crée les dossiers inexistants et copie les fichiers correspondants
    'adapter le nom de la feuille
    With Worksheets("Feuil1")
    
        For I = 2 To .Cells(.Rows.Count, "X").End(xlUp).Row
            
            'copie des fichiers
            If Fso.FileExists(DossierFichiers & .Cells(I, "X").Value & ".xls") = True Then
                
                Fso.CopyFile DossierFichiers & .Cells(I, "X").Value & ".xls", Dossier & .Cells(I, "X").Value & "\", True
                
            End If

        Next I
        
    End With
    
End Sub

Hervé.

 

[gigiati]

Re : Création de répertoire via macro

Superbe, milles merci à vous et désolé pour l'oublis...

Bonne journée