Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

déplacer des fichiers

14 réponses
Avatar
mabouille
Bonjour le monde,
Sous Vista, Excel 2003, j'ai sur mon PC un dossier "Trésorier" qui contient
des sous-dossiers (nombreux) et des fichiers (beaucoup), qui sont des .xls
mais pas seulement (.doc, .jpg, .txt aussi)
J'ai souvent besoin de trimballer tels ou tels fichiers pendant quelques
jours en les travaillant sur plusieurs bécanes sucessives. J'ai donc créé un
dossier "EN COURS" sur une clé USB.
Quand les fichiers sont "stabilisés" (fin provisoire d'une phase de boulot
sur eux), je les ramène sur mon ordi et je les range dans "C:\Trésorier" en
les supprimant de la clé USB. (où ils seront remplacés plus tard par une
nouvelle vague de fichiers d'actualité).

Normalement je fais ça "à la main" en utilisant couper coller de Windows
Explorer, mais comme il y en a beaucoup je voudrais procéder par une macro
qui vide"EN COURS" de tous ses fichiers et les remettent à leur place dans
"C:\Trésorier".

Quel code peut couper dans le dossier "EN COURS" le fichier "LesSous.xls"
récemment travaillé et le coller dans le dossier "C:\Trésorier\Banque" ? (en
écrasant bien sûr le fichier antérieur)
Précision : grâce à ceux qui aident ici (merci FdeCourt) j'ai eu une macro
Excel qui me liste sans problème dans une feuille Excel, la liste complète
des fichiers de "C\Trésorier" avec leur chemin d'accès complet, et idem pour
EN COURS évidemment. Mon seul problème (enfin je crois) est de couper coller
les fichiers nomades.

Et est ce que ça peut marcher avec les .doc, .jpg, .txt ?

J'espère que j'ai bien expliqué ?
Cordialement, Mabouille

4 réponses

1 2
Avatar
mabouille
Merci beaucoup michdenis,
Je vais décortiquer les codes que tu m'as envoyés pour tâcher de progresser
en vba car je pars d'un niveau bien au dessous d'eux. Où allez vous pêcher
ces instructions magiques, les amis ? Faut que je me fasse une biblio, et si
tu peux me conseiller là dessus aussi je suis preneur.
Ce n'est pas juste une formule, je vais vraiment le faire! (hé il y en a
quand même qui sont à ma portée, par ex les WidCard !)
Pour le moment j'ai réussi à résoudre mon problème, enfin ça a l'air, et je
remercie Daniel.C et toi pour avoir bien voulu me répondre aussi gentiment
que rapidement.
Cordialement,
Mabouille


"michdenis" a écrit dans le message de
news:
Un autre façon de procéder en utilisant des API de Windows

Tu exécutes la procédure Test en choisissant une des actions
suivantes : FO_MOVE ,FO_COPY , FO_DELETE, FO_RENAME
l'usage des WildCard est permis *.xls ou *.* ou "P*.xls"
Ce qui permet d'avoir une action respectivement sur :
A ) Tous les fichiers excel seulement "chemin*.xls"
B ) Tous les fichiers contenu dans le répertoire "chemin*.*"
C ) Tous les fichiers Excel dont le nom débute par la lettre P
"cheminp*.*"
D ) On peut aussi utiliser le WidCard "?" qui remplace un caractère
dans le nom du fichier à l'endroit désigné
Exemple : "Fichier1.xls" on pourrait écrire : "CheminFichier?.xls"
pour
obtenir tous les noms dont la racine est "fichier"+ un caractère .xls

'déclaration des variables, constantes et Api dans le haut d'un
'module standard :
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type

Const FO_MOVE = 1
Const FO_COPY = 2
Const FO_DELETE = 3
Const FO_RENAME = 4

Const FOF_SILENT = 4
Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _
(lpFileOp As SHFILEOPSTRUCT) As Long

Private Function CopieDossier(Source As String, Dest As String, _
Optional Action As Byte, Optional Animation As Boolean) As Boolean
Dim OpStruct As SHFILEOPSTRUCT

With OpStruct
.wFunc = Action
.pFrom = Source
.pTo = Dest
'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10
.fFlags = 4
End With
CopieDossier = IIf(SHFileOperationA(OpStruct), False, True)
End Function

'---------------------------------
Sub Test()

Dim Source As String
Dim Dest As String

Source = "c:UsersDMDocumentsTest1test*.*"
Dest = "c:UsersDMDocumentsTest1"

If CopieDossier(Source, Dest, FO_COPY, True) Then
MsgBox "Opération réussie"
Else
MsgBox "Un problème fut rencontré."
End If
End Sub
'---------------------------------




"mabouille" a écrit dans le message de
groupe de
discussion : #
Bonjour,
Ce code est pas mal au dessus de ma compétence, mais j'ai commencé dès
réception (merci pour ta rapidité) à travailler dessus, prudemment pour ne
pas écraser mes "vrais" fichiers!

Toutefois je sens vaguement que je ferais bien de simplifier ma question:

Soit une version actualisée de 3 fichiers Fich1 Fich2 Fich 3 dans le
dossier
ENCOURS de la clé USB branchée sur le PC et affectée au lecteur P:
Chemins: P:ENCOURSFich1 P:ENCOURSFich2 P:ENCOURSFich3

Soit sur mon PC un dossier C:Trésorier avec les 2 sous dossiers
DossierA et DossierB
-DossierA contient une version "ancienne" de Fich1 et de Fich2,
Chemins : C:TrésorierDossierAFich1 et
C:TrésorierDossierAFich2
-DossierB contient une version ancienne de Fich3 (ce n'est pas pour
compliquer, c'est vraiment le cas type que j'ai)
Chemin : C:TrésorierDossierBFich3

Je cherche à faire une macro qui remplace dans C: les anciennes versions
des fichiers Fich1 Fich2 et Fich3 par les nouvelles versions de ces
fichiers
situées dans la clé P: (et les enlève de la clé)
Voili voilà, est ce jouable ?
Cordialement,
Mabouille

"michdenis" a écrit dans le message de
news:
Bonjour,

La procédure ne prévoit qu'une clé d'installer au moment
de procéder.

La procédure suivante va recréer sur la clé le chemin indiqué
dans la procédure qui est le même que le répertoire à copier
"Chemin = "UsersDMDocumentstest1""
Si ce chemin existe déjà, elle ne touchera à rien. Elle fait seulement
ajouter les répertoires du chemin manquants.

Elle copiera tous les répertoires, sous-répertoires et fichiers du
répertoire "Test1" en écrasant si besoin sans rien demander.

À partir de cette procédure, il est facile de faire une routine
faisant l'inverse, de la clé au disque dur.

'-------------------------------------------
Sub test()
Dim LecteurSource As String, Prêt As Boolean
Dim LecteurDestination As String
Dim Chemin As String

'***********Variables à renseigner*********
LecteurSource = "c:"
Chemin = "UsersDMDocumentstest1"
'*******************************************

LecteurDestination = RemovableDisk(LecteurSource)
If LecteurDestination <> "" Then
Prêt = EstPret(LecteurDestination)
If Prêt = False Then
MsgBox "Le lecteur amovible n'est pas prêt."
Exit Sub
End If
Else
MsgBox "Aucun disque amovible détecté."
Exit Sub
End If

'Création du répertoire si nécessaire
Creer_Chemin LecteurDestination, LecteurDestination & Chemin

'Copie des fichiers vers la destination
Commande = Environ("comspec") & " /c Xcopy /S/E/Y " & _
LecteurSource & Chemin & " " & LecteurDestination & Chemin & ""

Shell Commande, 0

End Sub

'-------------------------------------------
Function RemovableDisk(MonLecteur As String)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!" & _
strComputer & "rootcimv2")
Set colDisks = objWMIService.ExecQuery _
("Select * from Win32_LogicalDisk")
For Each Objdisk In colDisks
'2 constante numérique pour disque dur "removable"
If Objdisk.DriveType = 2 Then
RemovableDisk = Objdisk.Name & ""
Exit Function
End If
Next
End Function

'-------------------------------------------
Function EstPret(Lecteur As String)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
For Each objdrive In colDrives
If Lecteur = objdrive & "" Then
If objdrive.IsReady = True Then
EstPret = objdrive.IsReady
End If
End If
Next
End Function
'-------------------------------------------
Sub Creer_Chemin(Racine, Chemin As String)
Dim Commande As String
'Crée le chemin indiqué si les répertoires ne
'sont pas présents. N'écrase rien !
ChDrive Racine
Commande = Environ("comspec") & " /c mkdir " & Chemin
Shell Commande, 0
End Sub
'-------------------------------------------





"mabouille" a écrit dans le message de
groupe de
discussion : #
Bonjour le monde,
Sous Vista, Excel 2003, j'ai sur mon PC un dossier "Trésorier" qui
contient
des sous-dossiers (nombreux) et des fichiers (beaucoup), qui sont des
.xls
mais pas seulement (.doc, .jpg, .txt aussi)
J'ai souvent besoin de trimballer tels ou tels fichiers pendant quelques
jours en les travaillant sur plusieurs bécanes sucessives. J'ai donc créé
un
dossier "EN COURS" sur une clé USB.
Quand les fichiers sont "stabilisés" (fin provisoire d'une phase de
boulot
sur eux), je les ramène sur mon ordi et je les range dans "C:Trésorier"
en
les supprimant de la clé USB. (où ils seront remplacés plus tard par une
nouvelle vague de fichiers d'actualité).

Normalement je fais ça "à la main" en utilisant couper coller de Windows
Explorer, mais comme il y en a beaucoup je voudrais procéder par une
macro
qui vide"EN COURS" de tous ses fichiers et les remettent à leur place
dans
"C:Trésorier".

Quel code peut couper dans le dossier "EN COURS" le fichier
"LesSous.xls"
récemment travaillé et le coller dans le dossier "C:TrésorierBanque" ?
(en
écrasant bien sûr le fichier antérieur)
Précision : grâce à ceux qui aident ici (merci FdeCourt) j'ai eu une
macro
Excel qui me liste sans problème dans une feuille Excel, la liste
complète
des fichiers de "CTrésorier" avec leur chemin d'accès complet, et idem
pour
EN COURS évidemment. Mon seul problème (enfin je crois) est de couper
coller
les fichiers nomades.

Et est ce que ça peut marcher avec les .doc, .jpg, .txt ?

J'espère que j'ai bien expliqué ?
Cordialement, Mabouille




Avatar
mabouille
Bonjour,
Non bien sûr, je le donne donc ci après. J' espère que ça passera sur le
fil, car c'est long.
Euh c'est un redoutable honneur, dans la mesure où j'ai pris parfois des
solutions certainement très "bourrin" faute de temps et surtout pour être
sûr de bien contrôler cette macro, qui pouvait mettre en danger les fichiers
!! S'il vous plaît soyez tous indulgents!!
Parmi les trucs bourrin je pense que la solution des Offset pourrait être
remplacée par un indexage des lignes parcourues dans les deux pages. Il y a
sûrement d'autres choses.

Par précaution avant de faire quoi que ce soit j'avais fait une sauvegarde
complète du contenu de la clé!!

Bon, action: la macro est dans un fichier "Gestion.xls" qui se trouve sur la
clé USB (comme ça on est sûr qu'elle est en place pour faire ce travail!) et
qui comprend aussi deux onglets appelés "Rép Général" et "Rép EN COURS".

J'ai mis le code dans trois modules, voici le contenu du premier:
======================================================== Sub PgmMaitre()

'crée d'abord les listes de dossiers et fichiers, par deux macros et un
complément.

InventaireENCOURS
' voir code plus loin, macro-fille qui fait l'inventaires du dossier "EN
COURS"
InventaireTOTAL
' voir code plus loin, fait l'inventaires du dossier "C:Trésorier"
contenant tout, y compris une copie de "EN COURS"

'ensuite :
'le dossier "EN COURS", qui est la source, ne doit pas figurer dans la liste
des destinations
'aussi faut il éliminer toutes les adresses s'y référant dans la feuille
"Rép Général"
'on explore toutes les cellules de la colonne A jusqu'en bas de la liste
(test= 1ère cellule vide)
'pour repérer la présence de EN COURS et éliminer toute la ligne
correspondant.

Sheets("Rép Général").Activate
Range("A1").Select

Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Value Like ("*" & "EN COURS" & "*") Then
Selection.EntireRow.Delete
ActiveCell.Offset(-1, 0).Activate ' ça c'est parce que la ligne
active étant éliminée c'est la suivante qui devient la sélection
' il faut donc
remonter d'un cran la sélection sinon on loupe d'examiner cette ligne au
tour suivant
End If
Loop
'======================================== 'repérage des adresses du dossier "C:Trésorier" où sont rangés les fichiers
se trouvant dans EN COURS s'ils ont déja été rangés une fois.

'pour cela on explore cellule par cellule la colonne C (nom des fichiers) de
la page Rép EN COURS
'pour chaque cellule on cherche si le fichier figure dans la colonne B de la
page Rép Général
'par précaution on parcourt la totalité de cette colonne, au cas où un même
fichier aurait deux adresses.

Sheets("Rép EN COURS").Activate
Range("C1").Select
Do While ActiveCell.Value <> ""
' ici on mémorise la date de modification et le nom du fichier qui sera peut
être à déplacer,

Sheets("Rép EN COURS").Activate
ActiveCell.Offset(1, 4).Activate ' va dans la colonne des dates
modif
DateModifSource = ActiveCell.Value
ActiveCell.Offset(0, -4).Activate 'retourne à la colonne des noms
FichRech = ActiveCell.Value 'vb pour chercher le fichier dans
l'autre page

' puis on recherche ce fichier d'après les noms listés dans Rép
Général
Sheets("Rép Général").Activate
Range("C1").Select

Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Activate

If ActiveCell.Value Like (FichRech) Then
'si on trouve le fichier on vérifie quelle est la version la plus fraîche
ActiveCell.Offset(0, 4).Activate
DateModifCible = ActiveCell.Value
ActiveCell.Offset(0, -4).Activate

If DateModifSource >= DateModifCible Then
'si le fichier de EN COURS est plus récent, on le range à la place de son
ancienne version.
DéplacementFichiers
'puis on revient à la liste
Sheets("Rép Général").Activate
End If

End If
Loop

Sheets("Rép EN COURS").Activate

Loop

End Sub
========================================= ' Sous Macro, également dans le premier module,
' sur une suggestion + code de Daniel.C

Sub DéplacementFichiers()

ActiveCell.Offset(0, -1).Activate
FichierCible = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate

Sheets("Rép EN COURS").Activate
ActiveCell.Offset(0, -1).Activate
FichierSource = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate

On Error Resume Next
Kill FichierCible
Name FichierSource As FichierCible
Kill FichierSource 'pas utile, mais je l'ai gardée

Sheets("Rép Général").Activate

End Sub
========================================== ' 2ème module, macro appelée au début du prgm maître:
' solution trouvée sur internet, adaptée de Ole P Erlandsen
' necessite d'activer la reference Microsoft Scripting RunTime: dans
l'editeur Visual Basic (alt+F11)
' aller dans le menu 'outils - références' et cocher Microsoft running...

Option Explicit

Sub InventaireENCOURS()

Sheets("Rép EN COURS").Select

'efface la liste précédente
Cells.Select
Selection.ClearContents
Range("A1").Select

'liste le contenu de EN COURS sur la clé USB
ListFilesInFolder "P:TrésorierEN COURS", True

End Sub

Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As
Boolean)
Static fso As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.file
Static wksDest As Worksheet
Static iRow As Long
Static bNotFirstTime As Boolean

If Not bNotFirstTime Then
Set wksDest = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
'je n'ai pas eu besoin de tous, mais ici tous y sont
wksDest.Cells(1, 1) = "Parent folder"
wksDest.Cells(1, 2) = "Full path"
wksDest.Cells(1, 3) = "File name"
wksDest.Cells(1, 4) = "Size"
wksDest.Cells(1, 5) = "Type"
wksDest.Cells(1, 6) = "Date created"
wksDest.Cells(1, 7) = "Date last modified"
wksDest.Cells(1, 8) = "Date last accessed"
wksDest.Cells(1, 9) = "Attributes"
wksDest.Cells(1, 10) = "Short path"
wksDest.Cells(1, 11) = "Short name"

iRow = 2
bNotFirstTime = True
End If

Set oSourceFolder = fso.GetFolder(strFolderName)

For Each oFile In oSourceFolder.Files
wksDest.Cells(iRow, 1) = oFile.ParentFolder.Path
wksDest.Cells(iRow, 2) = oFile.Path
wksDest.Cells(iRow, 3) = oFile.Name
wksDest.Cells(iRow, 4) = oFile.Size
wksDest.Cells(iRow, 5) = oFile.Type
wksDest.Cells(iRow, 6) = oFile.DateCreated
wksDest.Cells(iRow, 7) = oFile.DateLastModified
wksDest.Cells(iRow, 8) = oFile.DateLastAccessed
wksDest.Cells(iRow, 9) = oFile.Attributes
wksDest.Cells(iRow, 10) = oFile.ShortPath
wksDest.Cells(iRow, 11) = oFile.ShortName

iRow = iRow + 1
Next oFile

If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.subfolders
ListFilesInFolder oSubFolder.Path, True
Next oSubFolder
End If

End Sub
================================================= ' 3ème module, macro appelée au début du prgm maître:
' idem la précédente = adaptée de Ole P Erlandsen
Option Explicit

Sub InventaireTOTAL()

Sheets("Rép Général").Select

'efface toute la liste précédente
Cells.Select
Selection.ClearContents
Range("A1").Select

'liste le contenu de l'ensemble du répertoire Trésorier
ListFilesInFolder "C:Trésorier", True

End Sub

Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As
Boolean)

Static fso As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.file
Static wksDest As Worksheet
Static iRow As Long
Static bNotFirstTime As Boolean

If Not bNotFirstTime Then
Set wksDest = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
'je n'ai pas eu besoin de tous, mais ici tous y sont
wksDest.Cells(1, 1) = "Parent folder"
wksDest.Cells(1, 2) = "Full path"
wksDest.Cells(1, 3) = "File name"
wksDest.Cells(1, 4) = "Size"
wksDest.Cells(1, 5) = "Type"
wksDest.Cells(1, 6) = "Date created"
wksDest.Cells(1, 7) = "Date last modified"
wksDest.Cells(1, 8) = "Date last accessed"
wksDest.Cells(1, 9) = "Attributes"
wksDest.Cells(1, 10) = "Short path"
wksDest.Cells(1, 11) = "Short name"

iRow = 2
bNotFirstTime = True
End If

Set oSourceFolder = fso.GetFolder(strFolderName)

For Each oFile In oSourceFolder.Files
wksDest.Cells(iRow, 1) = oFile.ParentFolder.Path
wksDest.Cells(iRow, 2) = oFile.Path
wksDest.Cells(iRow, 3) = oFile.Name
wksDest.Cells(iRow, 4) = oFile.Size
wksDest.Cells(iRow, 5) = oFile.Type
wksDest.Cells(iRow, 6) = oFile.DateCreated
wksDest.Cells(iRow, 7) = oFile.DateLastModified
wksDest.Cells(iRow, 8) = oFile.DateLastAccessed
wksDest.Cells(iRow, 9) = oFile.Attributes
wksDest.Cells(iRow, 10) = oFile.ShortPath
wksDest.Cells(iRow, 11) = oFile.ShortName

iRow = iRow + 1
Next oFile
oSubFolder

If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.subfolders
ListFilesInFolder oSubFolder.Path, True
Next oSubFolder
End If

End Sub
============================================= Voilà, tout y est, j'espère avoir correctement recopié.
Je l'ai faite tourner deux fois déjà, apparemment sans problème.
Merci pour l'aide que j'ai reçue, et pour l'indulgence de ceux qui liront
ça!!
Bien entendu toute suggestion pour améliorer sont les bienvenus.
Cordialement
Mabouille
Avatar
michdenis
Avatar
mabouille
Bonsoir,
Attention, je viens de trouver un petit bug: si un même fichier est classé
dans CTrésorier à deux endroits différents et si on a fait une modif (donc
placée dans EN COURS), seule l' "ancienne" version trouvée en premier par la
macro sera mise à jour puisque le fichier est supprimé de EN COURS au 1er
coup. Donc ne pas utiliser cette macro telle quelle si on est dans ce cas, à
savoir = possibilité de copies du même fichier dans plusieurs emplacements
de C:Trésorier. Ou sinon n'oubliez pas d'adapter le code.
Perso je n'ai ça que 2 ou 3 fois, donc je ne change rien, mais je vais
m'obliger à n'avoir qu'un exemplaire de chaque fichier, c'est d'ailleurs
plus "sain"!
Cordialement
Mabouille


"michdenis" a écrit dans le message de
news:
Merci.




1 2