Macro de déplacement de fichier

Version imprimable

1 pièce(s) jointe(s)

Bonjour a tous,

j'ai mon fichier excel, dans la feuille 'suivi' qui comprend tous les devis, je veux pouvoir déplacer les devis vers un autre dossier "04-clos" si le dossier d'origine n'est pas "04-clos". j'ai fait une macro pour un menu contextuelle de sorte a ce que si on choisi l'option déplacement il exécute la macro de déplacement. il se trouve que ma macro de déplacement ne fonctionne pas. merci de m'aider.
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 Sub Sub_Déplacement_Clos() Set fs = CreateObject("Scripting.FileSystemObject") Dim Sh_Suivi As Worksheet Set Sh_Suivi = Sheets("Suivi") l = 2 l_fin = 2 Compteur = 0 Do While Sh_Suivi.Cells(l, P_Suivi_CheminFichier).Value <> "" If Not (Sh_Suivi_PTV.Cells(l, P_Suivi_CheminFichier).Value Like "*04-Clos*") Then Set f = fs.GetFile(Sh_Suivi.Cells(l, P_Suivi_CheminFichier).Value) Fichier = f.Name fs.movefile f.Path, "C:\\04-Clos\\" Action = "Clos" Chemin = "C:\04-Clos\" & Fichier Compteur = Compteur + 1 l_fin = l_fin - 1 Do While Sh_Suivi.Cells(l_fin, P_Suivi_CheminFichier).Value <> "" l_fin = l_fin + 1 Loop Sh_Suivi.Cells(l_fin, P_Suivi_CheminFichier).Value = Chemin End If l = l + 1 Loop MsgBox Compteur & " fichiers déplacés", vbInformation, "Déplacement statut" End Sub
Après la ligne Set f = fs.GetFile(Sh_Suivi.Cells(l, P_Suivi_CheminFichier).Value)
il passe directement au End If

Name() et Dir()

(1) Pourquoi ne pas utiliser l'instruction Name OldName as NewName
(2) avant de déplacer un fichier, il serait utile de vérifier que ce fichier existe bien à l'endroit indiqué, et si non: le signaler

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Sub_Déplacement_Clos()
    Dim Sh_Suivi As Worksheet
    Dim FromPath As String, ToNewPath As String, kL As Long
    Set Sh_Suivi = Sheets("Suivi")
    kL = 2
    FromPath = Sh_Suivi.Cells(kL, 2)
    Do While FromPath <> ""
        If Not (FromPath Like "*04-Clos*") Then
            ToNewPath = "C:\04-Clos" & Mid(FromPath, InStrRev(FromPath, "\"))
            Debug.Print ToNewPath
            If Dir(FromPath) = "" Then
                MsgBox "Le fichier " & FromPath & " est manquant !", , "Anomalie"
            Else
                Name FromPath As ToNewPath
                Cells(kL, 2) = ToNewPath
            End If
        End If
        kL = kL + 1
        FromPath = Sh_Suivi.Cells(kL, 2)
    Loop
End Sub

Bonne continuation.

25/03/2016, 23h06
Invité

Bonjour,
Regarde ce lien tu y trouera ce que tu veux et plus!

http://www.developpez.net/forums/d15...l/#post8149786
31/03/2016, 15h46
bervellea1

Bonjour,
j'aimerais dire merci à tous ceux qui se sont penchés sur mon problème.
Merci particulier à EricDgn, ta solution avec quelques modifications a montré son efficacité.
Merci.