Deplacements de fichiers de dossier à dossier

Le 10/02/2014 à 16:32
Sub DeplacerFichiersEtape1(dosdestination as string)

Dim FSO As Object
Dim Dossier As Object
Dim Fichier As Object
Dim Nouvdos As Object

Dossier = "F:\Enregistrements_SOPHIA\"

'crée l'objet
Set FSO = CreateObject("Scripting.FileSystemObject")

'si le dossier cible n'existe pas, fin
If FSO.FolderExists(Dosdestination) = False Then Exit Sub

'défini le dossier où effectuer la recherche des fichiers et la création des dossiers
Set Dossier2 = FSO.getfolder(Dossier) 'parcour la collection de fichiers du dossier en cours
For Each Fichier In Dossier2.Files
msgbox(fichier.path)
msgbox(dosdestination & fichier.name)
Filecopy(fichier.path,dosdestination & fichier.name)
Kill Fichier.Path
Next

End Sub

donne mois les msgbox qui s'affichent

Le 10/02/2014 à 16:43

je t'ai fait une copie ecran....ce sera plus simple....

je clique sur mon bouton......

il m'affiche la ligne "filecopy ..........." en rouge....... avec le message d'erreur que tu vois sur la copie ecran

si je clique OK, il me surligne en jaune "Sub.........."

9engueengue.docx (60.11 Ko)
Le 10/02/2014 à 17:16

Quel con... Je mélange FSO et dos...

Ceci devrait le faire

Sub DeplacerFichiersEtape1(dosdestination as string)

Dim FSO As Object
Dim Dossier As Object
Dim Fichier As Object
Dim Nouvdos As Object

Dossier = "F:\Enregistrements_SOPHIA\"

'crée l'objet
Set FSO = CreateObject("Scripting.FileSystemObject")

'si le dossier cible n'existe pas, fin
If FSO.FolderExists(Dosdestination) = False Then Exit Sub

'défini le dossier où effectuer la recherche des fichiers et la création des dossiers
Set Dossier2 = FSO.getfolder(Dossier) 'parcour la collection de fichiers du dossier en cours
For Each Fichier In Dossier2.Files
msgbox(fichier.path)
msgbox(dosdestination & fichier.name)
Fso.copyfile(fichier.path,dosdestination & fichier.name)
Kill Fichier.Path
Next

End Sub
Le 10/02/2014 à 17:23

je pense que tu vas devenir aussi dingue que moi ....lol

nouveau message d'erreur..... cette foit une textbox direct sur ma feuille (cf copie écran)

quand je te dis que c'est un truc de fou !!!

8engue2.docx (121.34 Ko)
Le 10/02/2014 à 18:08

... Je ne vois pas d'où vient l'erreur.

Le 10/02/2014 à 18:21

j'ai trouvé le code ci dessous....

peut etre puis je l'adapter?

Sub Copie_Fichiers_Répertoire_Source()

Dim Source As String, Destination As String

Dim FSO As Object

'*********Variables à renseigner**********

Source = "c:\Test\"

Destination = "C:\Test_Test\"

'*****************************************

If Dir(Source, vbDirectory) <> "" Then

Set FSO = CreateObject("Scripting.FileSystemObject")

Boucle_Sur_Tout_Le_Répertoire FSO, Source, Destination

Set FSO = Nothing

End If

End Sub

'----------------------------------

Sub Boucle_Sur_Tout_Le_Répertoire(FSO As Object, _

Source As String, Destination As String)

Dim SubRep As Object

Dim Rep As Object

Dim Fichier As Object

With FSO

Set Rep = .GetFolder(Source)

'Boucle sur tous les fichiers du répertoire

For Each File In Rep.Files

'Copie les fichiers vers la destination

.CopyFile File, Destination, True

'Supprime les fichiers du répertoire source

.DeleteFile File, True

Next

End With

If Not Source Like "*System Volume Information*" Then

'Boucle sur tous les sous-répertoires

For Each SubRep In Rep.SubFolders

'Modification du chemin de la destination

Destination = Destination & SubRep.Name & "\"

'Vérifier si le répertoire existe dans le répertoire

'de destination, sinon création de celui-ci

If Dir(Destination, vbDirectory) = "" Then

FSO.CreateFolder Destination

End If

'Modification du répertoire Source

Source = Source & SubRep.Name & "\"

'Appel de la procédure

Boucle_Sur_Tout_Le_Répertoire FSO, Source, Destination

Next

End If

End Sub

Le 10/02/2014 à 18:50

Change ces deux lignes:

Fso.copyfile fichier, dosdestination, true

Fso.deletefile fichier, true

Le 10/02/2014 à 18:54

bon ..... le rouge disparait.....lol....

on progresse enfin je suis pas d'un grand secours....

desormais il me surligne Dossier = "F:\Enregistrements_SOPHIA\

Sub Macro10()

'

DeplacerFichiersEtape1 "F:\services\Appels\serveur MANAGEMENT V2.2014\SUIVI CENTRE\APPELS\Classement des appels enregistrés\"

End Sub

Sub DeplacerFichiersEtape1(dosdestination As String)

Dim FSO As Object

Dim Dossier As Object

Dim Fichier As Object

Dim Nouvdos As Object

Dossier = "F:\Enregistrements_SOPHIA\"'

crée l'objet

Set FSO = CreateObject("Scripting.FileSystemObject")

'si le dossier cible n'existe pas, fin

If FSO.FolderExists(dosdestination) = False Then Exit Sub

'défini le dossier où effectuer la recherche des fichiers et la création des dossiers

Set Dossier = FSO.GetFolder(Dossier) 'parcour la collection de fichiers du dossier en cours

For Each Fichier In Dossier.Files

FSO.copyfile Fichier, dosdestination, True

FSO.deletefile Fichier, True

Next

End Sub

Le 10/02/2014 à 18:56

Dim dossier

Vire le as object

Le 10/02/2014 à 19:10

ok, apres modif il bloque sur le fso

je te met une copie ecran.....

quand je te dis que je comprends pas tout..... en tout cas, chapeau pour ta patience ....!!!

et merciiiiiiiiiii

13engue3.docx (53.57 Ko)
Le 11/02/2014 à 09:08

bonjour....

bon j'ai un peu réflechi et modifié ce code.....

ça marche mais pas en entier...... il me copie bien les fichiers du sous repertoire source..... mais d'un seul sous sous repertoire ..... il ne boucle pas sur tous les sous sous repertoires

et il m'affiche donc ensuite en surlignage la ligne ci dessous....

Sub Copie_Fichiers_Répertoire_Source()

Dim Source As String, Destination As String

Dim FSO As Object

'*********Variables à renseigner**********

Source = "F:\Enregistrements_SOPHIA\"

Destination = "F:\services\Appels\serveur MANAGEMENT V2.2014\SUIVI CENTRE\APPELS\Classement des appels enregistrés\"

'*****************************************

If Dir(Source, vbDirectory) <> "" Then

Set FSO = CreateObject("Scripting.FileSystemObject")

Boucle_Sur_Tout_Le_Répertoire FSO, Source, Destination

Set FSO = Nothing

End If

End Sub

'----------------------------------

Sub Boucle_Sur_Tout_Le_Répertoire(FSO As Object, _

Source As String, Destination As String)

Dim SubRep As Object

Dim Rep As Object

Dim Fichier As Object

With FSO

Set Rep = .GetFolder(Source)'

Boucle sur tous les fichiers du répertoire

For Each File In Rep.Files

'Copie les fichiers vers la destination

.CopyFile File, Destination, True

'Supprime les fichiers du répertoire source

.DeleteFile File, True

Next

End With

If Not Source Like "*System Volume Information*" Then

'Boucle sur tous les sous-répertoires

For Each SubRep In Rep.SubFolders

'Modification du chemin de la destination

Destination = Destination

'Vérifier si le répertoire existe dans le répertoire

'de destination, sinon création de celui-ci

If Dir(Destination, vbDirectory) = "" Then

FSO.CreateFolder Destination

End If

'Modification du répertoire Source

Source = Source & SubRep.Name & "\"

'Appel de la procédure

Boucle_Sur_Tout_Le_Répertoire FSO, Source, Destination

Next

End If

End Sub

Le 14/02/2014 à 11:11

bonjour,

quelqu'un a une idée pour m'aider?

merci à tous

Rechercher des sujets similaires à "deplacements fichiers dossier"