Supprimer ou déplacer fichiers en fction d'une indication

zeltron

XLDnaute Occasionnel
Bonjour à tous,

Je souhaiterais pouvoir déplacer ou supprimer des fichiers dont le chemin est indiqué.

En fonction de l'indication en colonne "E"; le fichier est supprimé si l'indication est "S" ou déplacé si l'indication est "D" ou bien il ne se passe rien si rien n'est indiqué.

Pour les fichiers déplacés, je souhaiterais qu'ils soient déplacés à l'endroit indiqué en colonne "F". Mais que si le répertoire n'existe pas, la macro le crée.

J'ai regardé sur le site, mais je n'ai pas trouvé, de près ou de loin, de fil de discussion sur ce problème.
Je vous remercie par avance pour votre aide
Cordialement

Zeltron
 

Pièces jointes

  • SuppOuDeplacer_Fichiers.xlsx
    11.9 KB · Affichages: 28

Dranreb

XLDnaute Barbatruc
Re : Supprimer ou déplacer fichiers en fction d'une indication

Bonjour.

Pour la suppression c'est simple, c'est Kill CheminNomFic

Pour le déplacement, testez cette procédure avec quelques fichiers et répertoires bidons dans différents cas de figures.
Ce ne sera plus rien, ensuite, si elle marche bien, de l'invoquer dans une boucle qui explore la liste.
VB:
Sub Déplacer(ByVal NomFic As  String, ByVal ChDépart As String, ByVal ChArrivée As String)
Dim TSp() As String, P As Long, Inexistant As Boolean
If Right$(ChDépart, Len(NomFic) + 1) <> "\" & NomFic Then
   TSp = Split(ChDépart, "\")
   ReDim TSp(0 To UBound(TSp) + 1)
   TSp(UBound(TSp)) = NomFic
   ChDépart = Join(TSp, "\"): End If
On Error Resume Next: ChDir ChArrivée
Inexistant = Err > 0: On Error GoTo 0
If Inexistant Then
   ChDrive ChArrivée
   TSp = Split(ChArrivée, "\")
   For P = 0 To UBound(TSp)
      On Error Resume Next: ChDir TSp(P)
      Inexistant = Err > 0: On Error GoTo 0
      If Inexistant Then
         MkDir TSp(P)
         ChDir TSp(P)
         End If: Next P: End If
Name ChDépart As ChArrivée & "\" & NomFic
End Sub

Remarque: je me suis basé sur cette remarque dans l'aide concernant l'intruction Name
L'instruction Name renomme un fichier et le déplace le cas échéant vers un nouveau répertoire ou dossier. Elle permet aussi de déplacer un fichier d'un lecteur à un autre, mais elle ne peut renommer un dossier existant que si les arguments newpathname et oldpathname concernent le même lecteur. L'instruction Name ne permet pas de créer un nouveau fichier ou dossier.
 
Dernière édition:

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Merci Dranreb pour ton retour rapide.

Cependant je ne sais pas comment intégrer ton code même pour tester une ligne.

Peux tu m'indiquer dans ton code où on doit indiquer la ligne concernée?

T'en remerciant par avance

Cordialement

Zeltron
 

Pièces jointes

  • SuppOuDeplacer_Fichiers v2.xlsm
    20.8 KB · Affichages: 24

Dranreb

XLDnaute Barbatruc
Re : Supprimer ou déplacer fichiers en fction d'une indication

Je n'ai pas testé ma procédure.
Alors avant d'écrire une boucle qui l'utilisera dans une macro à affecter à un bouton, que vous écrirez, je vous demande de la tester.
Donc vous faites plein d'essais du genre créer un répertoire Test sur F, vous y mettez un fichier Toto.xlsx, vous lancez cette procédure :
VB:
Sub test()
Déplacer "Toto.xlsx", "F:\Test", "G:\TestA\Recup\C\ZZ"
End Sub
Et vous vérifiez que votre Toto.xlsx a bien été déplacé de F:\Test vers G:\TestA\Recup\C\ZZ.
 

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Dranreb,

J'ai voulu commencer les test mais la macro bloque et me surligne en jaune la ligne suivante de ton code:
Name ChDépart As ChArrivée & "\" & NomFic

Pour être exhaustif le répertoire manquant n'a pas non plus été crée.

Cordialement

Zeltron
 

Dranreb

XLDnaute Barbatruc
Re : Supprimer ou déplacer fichiers en fction d'une indication

Précisez: Erreur de compilation ou d'exécution ? Quel est la description du message d'erreur ?
Ça peut être dû au répertoire d'arrivée qui n'a pas été créé.
Mettez un point d'arrêt sur le premier On Error Resume Next.
Mettez un espion sur CurDir et déroulez en pas à pas.

Je crois que je viens de trouver la cause : ChDir "G:" ne revient pas à la racine de G. Il Faut ChDir "G:\"
alors faites tourner la boucle à partir de TSp(1) pour sauter le TSp(0) mais mettez devant
VB:
ChDir TSp(0) & "\"
   For P = 1 To UBound(TSp)
Si cette hypothèse est exacte ça devrait avoir créé plein de sous dossiers derrière celui courant, à ce moment là, dans G, au lieu de les avoir créé à sa racine.
 
Dernière édition:

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Il est indiqué:
Erreur d'execution '53'
Fichier Introuvable

Et ensuite il me propose fin ou debuggage. Et quand je clique sur débuggage la ligne "Name ChDépart As ChArrivée & "\" & NomFic" est surlignée en jaune, et pas plus d'indication.
Or, j'ai bien vérifié le fichier "Toto.xlsx" se trouve bien dans le répertoire: F:\Test\

Cordialement
Zeltron
 

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Oui, cela a crée plusieurs repertoires et sous repertoires dans le repertoire où se trouve le fichier contenant la macro.
J'ai essayé de suivre vos instructions pour la modification du code, mais cela donne exactement le même message d'erreur.

Mais je pense que j'ai mal modifié le code selon vos directives. Je me permets de le mettre ci-après:

Private Sub CommandButton1_Click()
Déplacer "Toto.xlsx", "F:\Test", "G:\TestA\Recup\C\ZZ"
End Sub

Sub Déplacer(ByVal NomFic As String, ByVal ChDépart As String, ByVal ChArrivée As String)
Dim TSp() As String, P As Long, Inexistant As Boolean
If Right$(ChDépart, Len(NomFic) + 1) <> "\" & NomFic Then
TSp = Split(ChDépart, "\")
ReDim TSp(0 To UBound(TSp) + 1)
TSp(UBound(TSp)) = NomFic
ChDépart = Join(TSp, "\"): End If
On Error Resume Next

Inexistant = Err > 0: On Error GoTo 0
If Inexistant Then
ChDrive ChArrivée
TSp = Split(ChArrivée, "\")
ChDir TSp(0) & "\"
For P = 0 To UBound(TSp)
On Error Resume Next: ChDir TSp(P)
Inexistant = Err > 0: On Error GoTo 0
If Inexistant Then
MkDir TSp(P)
ChDir TSp(P)
End If: Next P: End If
Name ChDépart As ChArrivée & "\" & NomFic
End Sub



Merci d'avance pour votre aide

Cordialement

Zeltron
 

Dranreb

XLDnaute Barbatruc
Re : Supprimer ou déplacer fichiers en fction d'une indication

Vous avez oublié de changer For P = 0 To UBound(TSp) en For P = 1 To UBound(TSp)
… et je ne vois plus non plus une instruction : ChDir ChArrivée derrièrre le 1er On Error Resume Next qui établissait déjà si l'ensemble du chemin cible n'existait pas.
 
Dernière édition:

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Je viens de changer le code:

Private Sub CommandButton1_Click()
Déplacer "Toto.xlsx", "F:\Test", "G:\TestA\Recup\C\ZZ"
End Sub

Sub Déplacer(ByVal NomFic As String, ByVal ChDépart As String, ByVal ChArrivée As String)
Dim TSp() As String, P As Long, Inexistant As Boolean
If Right$(ChDépart, Len(NomFic) + 1) <> "\" & NomFic Then
TSp = Split(ChDépart, "\")
ReDim TSp(0 To UBound(TSp) + 1)
TSp(UBound(TSp)) = NomFic
ChDépart = Join(TSp, "\"): End If
On Error Resume Next

Inexistant = Err > 0: On Error GoTo 0
If Inexistant Then
ChDrive ChArrivée
TSp = Split(ChArrivée, "\")
ChDir TSp(0) & "\"
For P = 1 To UBound(TSp)
On Error Resume Next: ChDir TSp(P)
Inexistant = Err > 0: On Error GoTo 0
If Inexistant Then
MkDir TSp(P)
ChDir TSp(P)
End If: Next P: End If
Name ChDépart As ChArrivée & "\" & NomFic
End Sub

Le message d'erreur reste le même.

Cordialement

Zeltron
 

zeltron

XLDnaute Occasionnel
Re : Supprimer ou déplacer fichiers en fction d'une indication

Du coup je viens d'essayer em mettant : "ReDim TSp(1 To UBound(TSp) + 1)"

Mais il ya egalement toujours le même message d'erreur

Cordialement

Cédric GUILLOU
 

Discussions similaires

Réponses
2
Affichages
366