Déplacement de fichier

Version imprimable

1 pièce(s) jointe(s)

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:

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.

Code:

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.

11/10/2012, 20h31
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.

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 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.

Merci.

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

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
'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

15/10/2012, 19h46
mercatog

Bonjour
Je peux savoir pour quelle(s) raison(s) tu as adopté une telle méthodologie?
15/10/2012, 22h45
gege765

Bonjour,

Je ne comprend pas trop le sens de la question

Le but est de déplacer des fichiers dans une arborescence.
Au départ tous les fichiers sont dans un même répertoire.
Dans ce répertoire il y a des fichiers vides que je ne souhaitez pas traiter.

En y réfléchissant peut être aurais-je du d'abord supprimer les fichiers vides présent dans le répertoire source avant de déplacer les fichiers.

Cordialement.
16/10/2012, 11h22
mercatog

Je parlais si cette ligne de code ne te permet pas de créer ton dossier s'il n'existe pas

Code:

If Dir(DossierCible, vbDirectory) = "" Then MkDir DossierCible
16/10/2012, 22h32
gege765

Citation:

Envoyé par mercatog

Je parlais si cette ligne de code ne te permet pas de créer ton dossier s'il n'existe pas

Code:

If Dir(DossierCible, vbDirectory) = "" Then MkDir DossierCible

Car avec cette ligne j'ai cette erreur : Erreur d’exécution 76, chemin d'accès introuvable.
16/10/2012, 22h49
mercatog

Ok, avec Mkdir tu crée un dossier dans un autre dossier seulement si ce dernier existe.
Noté.
16/10/2012, 23h03
gege765

Voilà c'est çà, or dans mon cas l'arborescence n'était pas forcément complète.

En tout cas merci de ton aide.