XL 2016 Déplacement de classeur

[Jielgé]

Bonjour,
Je voudrais savoir s'il existe un code VBA pour déplacer un fichier d'un répertoire à un autre.
Merci !

 

[wDog66]

Bonjour,
Alors tout dépend ou ce trouve le fameux fichier et les répertoires source et de destination
Mais sinon oui en principe 😜

 

[Jielgé]

Bonjour,
Alors tout dépend ou ce trouve le fameux fichier et les répertoires source et de destination
Mais sinon oui en principe 😜

Répertoire source : "C:\Users\G\Documents\Fichiers à traiter\"
Répertoire de destination : "C:\Users\G\Documents\Fichiers traités\"
Fichier : Données.xlsx

 

[job75]

Bonsoir Jielgé, wDog66,

Exécutez cette macro :

Sub Deplacer_fichier()
Dim fichier$, source$, destination$, fso As Object
fichier = "Données.xlsx"
source = "C:\Users\G\Documents\Fichiers à traiter\" & fichier
destination = "C:\Users\G\Documents\Fichiers traités\" & fichier
Set fso = CreateObject("Scripting.FileSystemObject")
fso.movefile source, destination
End Sub

A+

 

[Dranreb]

Bonsoir.
Dans ce cas précis où le fichier demeure sur le même support, je pense qu'on peut simplement utiliser une vraie instruction basique de VBA :

Name "C:\Users\G\Documents\Fichiers à traiter\Données.xlsx" _
    As "C:\Users\G\Documents\Fichiers traités\Données.xlsx"

 

[job75]

Hello Bernard,

Pourquoi parles-tu de "support" ? A priori les 2 solutions fonctionnent quels que soient les dossiers.

Le dossier de destination ne doit pas contenir le fichier.

A+

 

[Dranreb]

Bonjour job75.
Pas s'ils sont sur des lecteurs différents, il semblerait.
À moins que ce soit détecté et que dans ce cas un MoveFile soit assumé automatiquement.
Mais ça m'étonnerait parce qu'en principe cette instruction ne déplace pas le fichier, elle change seulement sa référence, même si cela touche des noms de sous dossiers au lieu de son propre nom.

 

[Jielgé]

Bonsoir Jielgé, wDog66,

Exécutez cette macro :

Sub Deplacer_fichier()
Dim fichier$, source$, destination$, fso As Object
fichier = "Données.xlsx"
source = "C:\Users\G\Documents\Fichiers à traiter\" & fichier
destination = "C:\Users\G\Documents\Fichiers traités\" & fichier
Set fso = CreateObject("Scripting.FileSystemObject")
fso.movefile source, destination
End Sub

A+

Bonjour à tous,
En fait, je souhaite déplacer un grand nombre de fichiers. J'ai donc légèrement modifié la macro de Job75, et ça marche !!!

Sub Deplacer_fichier()
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fichier$, source$, destination$, fso As Object
fichier = Dir("C:\Users\...\Fichiers à traiter\" & "*.xlsx")
Do While fichier <> ""
source = "C:\Users\...\Fichiers à traiter\" & fichier
destination = "C:\Users\...\Fichiers traités\" & fichier
Set fso = CreateObject("Scripting.FileSystemObject")
fso.movefile source, destination
fichier = Dir
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[patricktoulon]

Bonjour
si tu modifie un code que l'on te donne fait le bien
l'object FSO est un gros lourdaud le recréer a chaque fichier n'est pas nécessaire
et il y a filecopy aussi qui fonctionne très bien et qui est intégré dans excel

les 3 méthodes​

Méthode FSO

Sub Deplacer_fichier()
    'gel de l'ecran
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim fichier$, DossierSource$, DossierDestination$, FSO As Object 'variables necessaires
  
  
    'veiller  à ce que les chemin de dossiers terminent bien par un slach
    DossierSource = "C:\Users\...\Fichiers à traiter\"
    DossierDestination = "C:\Users\...\Fichiers traités\"
  
    fichier = Dir(DossierSource & "*.xlsx") 'on lance un premier dir
  
    If fichier <> "" Then 'si il y a quelque chose on continue
      
        Set FSO = CreateObject("Scripting.FileSystemObject") 'le FSO on ne le crée qu'une fois
      
        Do While fichier <> ""
            FSO.movefile DossierSource & fichier, DossierDestination & fichier
            fichier = Dir
            DoEvents
        Loop
    End If
  
    'degel de l'ecran
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Méthode FileCopy

Sub Deplacer_fichier2()
    'gel de l'ecran
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim fichier$, DossierSource$, DossierDestination$ 'variables necessaires
  
    'veiller  à ce que les chemin de dossiers terminent bien par un slach
    DossierSource = "C:\Users\...\Fichiers à traiter\"
    DossierDestination = "C:\Users\...\Fichiers traités\"
  
    fichier = Dir(DossierSource & "*.xlsx") 'on lance un premier dir
  
    If fichier <> "" Then 'si il y a quelque chose on continue
      
               Do While fichier <> ""
            FileCopy DossierSource & fichier, DossierDestination & fichier
            fichier = Dir
            DoEvents
        Loop
    End If
  
    'degel de l'ecran
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Méthode Name AS NewName

Sub Deplacer_fichier3()
    'gel de l'ecran
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim fichier$, DossierSource$, DossierDestination$, 'variables necessaires
  
  
    'veiller  à ce que les chemin de dossiers terminent bien par un slach
    DossierSource = "C:\Users\...\Fichiers à traiter\"
    DossierDestination = "C:\Users\...\Fichiers traités\"
  
    fichier = Dir(DossierSource & "*.xlsx") 'on lance un premier dir
  
    If fichier <> "" Then 'si il y a quelque chose on continue
      
        Do While fichier <> ""
            Name DossierSource & fichier As DossierDestination & fichier
            fichier = Dir
            DoEvents
        Loop
    End If
  
    'degel de l'ecran
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Patrick