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

[zeltron]

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

 

[zeltron]

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

Je viens de modifier le code comme ceci, en remettant le le ChDir:

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, "\")
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

Cordialement

Cédric GUILLOU

 

[Dranreb]

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

Non ! Split rend toujours un tableau commençant à 0 mais l'élément 0 ne peut pas être utilisé à l'intérieur de la boucle parce qu'il contient "G:" au lieu de "G:\". Alors il faut le faire avant la boucle en concaténant un "\" derrière.

Ah : C'est bon ce coup ci ?
Il faudrait quand même étoffer ça poure que ça marche aussi notamment si le fichier source n'existe pas ou que le cible existe déjà.

Après il ne restera plus que le tout simple :

Private Sub CommandButton1_Click()
Dim T(), L&
T = Me.[C5:F5].Resize(Me.[C5000].End(xlUp).Row - 4).Value
For L = 1 To UBound(T)
   Select Case T(L, 3)
      Case "D": Déplacer T(L, 1), T(L, 2), T(L, 4)
      Case "S": Kill T(L, 2)
      End Select: Next L
End Sub

 

[zeltron]

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

Excusez moi, je n'ai pas erminer mon dernier message.

Donc en remmettant le chdir comme indiqué ci avant.

Le message d'erreur reste le même

Cordialement

Zeltron

 

[Dranreb]

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

Essayez peut être en étoffant un peu la fin, des fois qu'on y verrait plus clair :

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 Preserve 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, "\")
   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
On Error Resume Next
Name ChDépart As ChArrivée & "\" & NomFic
If Err Then
   Dim Z As String
   Z = "CurDir = """ & CurDir & """."
   If Dir(ChDépart) = "" Then Z = Z & vbLf & """" & ChDépart & """ n'existe pas."
   If Dir(NomFic) = NomFic Then Z = Z & vbLf & """" & CurDir & "\" & NomFic & """ existe déjà."
   Z = Z & vbLf & "Name """ & ChDépart & """ As """ & ChArrivée & "\" & NomFic & """" _
      & vbLf & "==> Erreur " & Err.Number & " :" & vbLf & Err.Description
   MsgBox Z, vbCritical, "Déplacer": End If
End Sub

Edit: je redonne toute la procédure parce que je vois que j'ai oublié le mot clé Preserve dans un Redim dans la 1ère phase.

D'ailleurs je me suis bien compliquer la vie à l'écrire comme ça au lieu de comme ceci :

If Right$(ChDépart, Len(NomFic) + 1) <> "\" & NomFic Then
   ChDépart = ChDépart & "\" & NomFic: End If

À supposer qu'il fallait l'écrire…

Forcément c'est toujours là ou on ne fait pas attention parce que c'est secondaire qu'il y a les plus énormes bogue !

 

[zeltron]

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

J'ai donc remis votre nouveau code ci après:

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 Preserve 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, "\")
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
On Error Resume Next
Name ChDépart As ChArrivée & "\" & NomFic
If Err Then
Dim Z As String
Z = "CurDir = """ & CurDir & """."
If Dir(ChDépart) = "" Then Z = Z & vbLf & """" & ChDépart & """ n'existe pas."
If Dir(NomFic) = NomFic Then Z = Z & vbLf & """" & CurDir & "\" & NomFic & """ existe déjà."
Z = Z & vbLf & "Name """ & ChDépart & """ As """ & ChArrivée & "\" & NomFic & """" _
& vbLf & "==> Erreur " & Err.Number & " :" & vbLf & Err.Description
MsgBox Z, vbCritical, "Déplacer": End If
End Sub

Mais cette fois ci j ai le type d erreur suivant:

erreur d'execution '68'
périphérique non disponible

Et il me surligne en jaune la ligne suivante: ChDrive ChArrivée

J'ai changé l'emplacement des fichiers sur d'autres disques, même dans le meme lecteur

Il me met toujours cette erreur

Cordialement

Zeltron

 

[Dranreb]

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

C'est que le 1er caractère du String ChArrivée ne doit pas être une lettre correspondant à un lecteur accessible.

ChDrive, instruction


Change le lecteur en cours.
Syntaxe
ChDrive drive
L'argument drive est une expression de chaîne désignant un lecteur existant. Si vous indiquez une chaîne de longueur nulle (""), le lecteur courant reste le même. Si l'argument drive est une chaîne à plusieurs caractères, l'instruction ChDrive n'utilise que la première lettre.

Vous pouvez mettre des contrôles aussi sur cette instruction :

On Error Resume Next: ChDrive ChArrivée
   If Err Then MsgBox "Impossible de positionner """ & Left$(ChArrivée, 1) _
      & """ comme lecteur courant." & vbLf & Err.Description, _
      vbCritical, "Déplacer": Exit Sub
   On Error GoTo 0

 

[zeltron]

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

Dranreb,

J'ai mis votre complément de code comme ceci:

Private Sub CommandButton1_Click()
Déplacer "Toto.xlsx", "C:\Test", "C:\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 Preserve 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
'***********************
On Error Resume Next: ChDrive ChArrivée
If Err Then MsgBox "Impossible de positionner """ & Left$(ChArrivée, 1) _
& """ comme lecteur courant." & vbLf & Err.Description, _
vbCritical, "Déplacer": Exit Sub
On Error GoTo 0
'***********************
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
On Error Resume Next
Name ChDépart As ChArrivée & "\" & NomFic
If Err Then
Dim Z As String
Z = "CurDir = """ & CurDir & """."
If Dir(ChDépart) = "" Then Z = Z & vbLf & """" & ChDépart & """ n'existe pas."
If Dir(NomFic) = NomFic Then Z = Z & vbLf & """" & CurDir & "\" & NomFic & """ existe déjà."
Z = Z & vbLf & "Name """ & ChDépart & """ As """ & ChArrivée & "\" & NomFic & """" _
& vbLf & "==> Erreur " & Err.Number & " :" & vbLf & Err.Description
MsgBox Z, vbCritical, "Déplacer": End If
End Sub



Le messagebox m'indique ceci: " Impossible de positionner "G" comme lecteur courant. Périphérique non disponible."

Je ne vois pas dans le code où on lui dit de chercher le lecteur "G", j'ai même tout mis sur le lecteur C

Là je ne comprends pas

Avez vous une idée??
Cordialement

Zeltron

 

[Dranreb]

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

J'essaie de me positionner sur le lecteur du chemin de destination pour pouvoir y créer, à partir de la racine s'il le faut, tout les sous répertoires successifs qui manquent pour former le chemin de destination du fichier, vu qu'il est établi que ce chemin n'existe pas dans son intégralité. Mais là vous devez certainement exécuter une procédure de test différente de celle que je vois au début de votre code, toujours reproduit sans balises pour m'en faciliter la lisibilité, soit dit en passant…

 

[zeltron]

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

Merci beaucoup,

Ca marche nickel, je continue les tests.

Je vais ensuite essayer de faire une boucle sur le tableau et reviendrai vers vous

Merci encore Dranreb

Cordialement

Zeltron

 

[zeltron]

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

Merci Dranreb,

J'ai testé plusieurs cas, cela fonctionne bien.
J'ai réussi à faire la boucle sur le tableau en cherchant sur le site. Cela fonctionne bien aussi.
Je met le fichier joint afin que cela puisse servir à d'autres


Merci encore

Cordialement

Zeltron