Discussion :

[Thierry1001]

Bonjour,

Je souhaiterai céer une macro qui tranfère des fichiers en .tif ou .pdf d'un dossier à un autre sans les ouvrirs.
Ces fichiers sont listés dans une feuille excel, avec leur adresse de destination (qui est différence pour chaque fichier)
Ces fichiers sont présents dans un seul dossier de mon ordinateur.
Dans ma macro, je récupère le nom du fichier et sa future adresse dans le tableur excel. Je le recherche dans le dossier ou il est situé physiquement et je voudrais le déplacer dans la nouvelle adresse sans l'ouvrir.
Est-ce possible. Je n'ai pas trouvé de code

J'ai mis le code de la macro ci-après

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Macro1()
Application.ScreenUpdating = False
Sheets("Docs&Links").Select
adresse3 = Cells(3, 6).Value
For ligne = 9 To 4000
If Cells(ligne, 6) = "" Then GoTo 1
adresse = Cells(ligne, 6).Value
adresse1 = Cells(ligne, 8).Value
'cherche le plan dans le fichier source
Set fs = Application.FileSearch
With fs
.LookIn = adresse3
.Filename = adresse
 
With Application.FileSearch
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
End With
' je veux transférer les fichier sélectionner dont l'adresse est "adresse3 & adresse" dans "adresse1"
 
1
Next
End Sub

Merci de votre aide

[kiki29]

Salut, brut de fonderie , à adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CopierFichier(ByVal sFichierACopier As String, ByVal sFichierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFile sFichierACopier, sFichierDestination, True
    Set FSO = Nothing
End Sub

Il existe également des instructions MoveFile et MoveFolder

Auquel on pourra adjoindre la création de dossier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
 
    ' Pour valeur retournée dans Rep
    ' Voir http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
End Sub
 
Sub Tst()
Dim Dossier As String
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
End Sub

[Thierry1001]

Bonjour,

Merci de la réponse mais je n'arrive pas à le faire fonctionner.


J'ai joint le une partie du fichier avec la macro. Si tu peux me donner une idée ou me modifier la macro en cours

Merci de ton aide

[kiki29]

Salut,en l'adaptant à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sDossierA As String, sDossierB As String
 
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
 
    sDossierA = "C:\Transfert"
    sDossierB = Dossier
 
    CopierDossier sDossierA, sDossierB
End Sub

[Thierry1001]

Merci pour ton code mais je voudrai transférer fichier par fichier et nom le dossier complet
Voici ma macro avec l'adresse des fichier (adresse1), le nom des fichiers à tranférer (adresse) et l'adresse de destination des fichier (adresse2)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sDossierA As String, sDossierB As String
Dim adresse As Variant
Dim adresse1 As Variant
Dim adresse2 As Variant
Dim ligne As Variant
 
Sheets("Docs&Links").Select
adresse2 = Cells(3, 6).Value ' adresse de destination
For ligne = 9 To 4000
If Cells(ligne, 6) = "" Then GoTo 1
adresse = Cells(ligne, 6).Value 'nom du fichier à déplacer
adresse1 = Cells(ligne, 8).Value ' adresse du fichier d'origine
 
    Dossier = adresse1 & adresse
    CreationDossier Dossier
 
    sDossierA = adresse2 & adresse
    sDossierB = Dossier
 
    CopierDossier sDossierA, sDossierB
1
Next
End Sub

[kiki29]

Salut, à adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierFichier(ByVal sFichierACopier As String, ByVal sFichierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFile sFichierACopier, sFichierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sFichier As String
 
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
 
    sFichier = ThisWorkbook.Path & "\" & "IE_Jscript.xls"
    CopierFichier sFichier, Dossier & "\" & "IE_Jscript.xls"
 
End Sub