Discussion :

[gege765]

Bonsoir,

Voilà je souhaite déplacer des fichiers d'un répertoire source identique vers un répertoire de destination précisé en colonne B.
Le nom du fichier à déplacer se situe en colonne A.

Actuellement mon code déplace uniquement les fichiers sans prendre en compte le répertoire ?

Que dois-je modifier à ma macro ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub DéplacerFichiers(Dequel_dossier$, A_queldossier$)
    Dim fso As Object
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    For i = 1 To Sheets(1).Range("a65536").End(xlUp).Row
        fso.MoveFile Dequel_dossier & "\" & Cells(i, 1), A_queldossier & "\"
    Next
    On Error GoTo 0
End Sub

Merci.

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub test()
 
DeplacerFichiers "C:\Users\user\Desktop\Source"
End Sub
 
Sub DeplacerFichiers(ByVal DossierSource As String)
Dim Fichier As String, DossierCible As String
Dim Fso As Object
Dim i As Long
 
Set Fso = CreateObject("Scripting.FileSystemObject")
With Worksheets(1)
    For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
        Fichier = .Range("A" & i).Value
        DossierCible = .Range("B" & i).Value
        If Dir(DossierCible, vbDirectory) <> "" And DossierCible <> "" Then
            If Dir(DossierSource & "\" & Fichier) <> "" And Dir(DossierCible & "\" & Fichier) = "" Then Fso.MoveFile DossierSource & "\" & Fichier, DossierCible & "\"
        End If
    Next i
End With
Set Fso = Nothing
End Sub

Déplace les fichiers de la colonne A à partir de DossierSource (s'ils existent) vers les dossiers de la colonne B s'ils existent.

[gege765]

Super merci

Y a-t-il possibilité de créer le répertoire de destination si ce dernier n'existe pas et de copier les fichiers qui lui sont affectés.

Merci.

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub test()
 
DeplacerFichiers "C:\Users\user\Desktop\"
End Sub
 
Sub DeplacerFichiers(ByVal DossierSource As String)
Dim Fichier As String, DossierCible As String
Dim Fso As Object
Dim i As Long
 
Set Fso = CreateObject("Scripting.FileSystemObject")
With Worksheets(1)
    For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
        Fichier = .Range("A" & i).Value
        DossierCible = .Range("B" & i).Value
        If DossierCible <> "" Then
            If Dir(DossierCible, vbDirectory) = "" Then MkDir DossierCible
        End If
        If Dir(DossierSource & "\" & Fichier) <> "" And Dir(DossierCible & "\" & Fichier) = "" Then Fso.MoveFile DossierSource & "\" & Fichier, DossierCible & "\"
    Next i
End With
Set Fso = Nothing
End Sub

Attention quand même à la validité de la donnée concernant les dossiers en colonne B.

[gege765]

Merci.

Voilà j'ai complété un peu la macro.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'Création de répertoires réccursifs si nécessaire
Sub CreerRep(Chemin)
    Dim oFSO
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If Not oFSO.FolderExists(Chemin) Then
        CreerRep (oFSO.GetParentFolderName(Chemin))
        oFSO.CreateFolder (Chemin)
    End If
End Sub
' Déplacer des fichier non vide d'un répertoire source vers un répertoire de destination
' Si le répertoire de destinatation n'existe pas, il sera crréé.
Sub DeplacerFichiers(ByVal DossierSource As String)
    Dim Fichier As String, DossierCible As String
    Dim Fso As Object
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    With Worksheets(1)
        For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            Fichier = .Range("A" & i).Value
            DossierCible = .Range("B" & i).Value
            'si dossier cible n'est pas vide
            If DossierCible <> "" Then
                If Dir(DossierCible, vbDirectory) = "" Then CreerRep (DossierCible)
            End If
            'test si les chemins source et cible sont bien des repertoires
            If Dir(DossierSource & "\" & Fichier) <> "" And Dir(DossierCible & "\" & Fichier) = "" Then
                'si le fichier source n'est pas vide alors on le déplace
                If Fso.GetFile(DossierSource & "\" & Fichier).size <> 0 Then
                    Fso.MoveFile DossierSource & "\" & Fichier, DossierCible & "\"
                End If
            End If
        Next i
    End With
    Set Fso = Nothing
End Sub

[mercatog]

Bonjour
Je peux savoir pour quelle(s) raison(s) tu as adopté une telle méthodologie?