Aide sur macro deplacement fichiers

  • Initiateur de la discussion Initiateur de la discussion sri75
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

sri75

XLDnaute Occasionnel
Bonjour, j'ai adapté cette macro pour pouvoir déplacer tous les fichiers d'un répertoire sous windows, avec une gestion d'erreur si le fichier existe déja dans le répertoire de destination.

Dans mon module de gestion d'erreur j'ai une erreur 58 à la ligne fso.MoveFile origine & Monfichier, destination & Monfichier

alors que normalement l'erreur 58 est gérée. Si j'ai 5 fichiers, pour la première gestion d'erreur c'est ok mais c'est quand je passe au deuxième fichier que ca plante.

Merci pour vos conseils.








Sub copieecrasante2()


Dim fso As Object, origine As String
Dim destination As String, reponse As Integer
Dim sortie As Byte, message As String
On Error GoTo camarchepas

debut:


origine = "c:\toto\"
destination = "c:\titi\"


Monfichier = Dir(origine & "*.*")

If Monfichier <> "" Then




'Ca plante à la ligne du dessous"

Set fso = CreateObject("scripting.filesystemobject")

fso.MoveFile origine & Monfichier, destination & Monfichier

GoTo debut


Exit Sub
camarchepas:
Select Case Err
Case 58
message = "Le fichier " & destination & " existe déjà" & _
vbNewLine & "Désirez vous le supprimer?"
reponse = MsgBox(message, vbQuestion + vbOKCancel, "Erreur")
Select Case reponse
Case vbOK
Kill destination & Monfichier
fso.MoveFile origine & Monfichier, destination & Monfichier
Case Else
sortie = 1
End Select
Case 53
message = "Le fichier " & origine & " n'existe pas" & _
vbNewLine & "Fin du programme"
MsgBox message
Case Else
End Select


GoTo debut

End If

End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour