[XL-2010] Copier une partie des répertoires et fichiers d'un dossier [Résolu]

[HERVE57]

Bonjour!
En VBA sous excel, je cherche, à l'aide d'une macro, à copier tous les dossiers et fichiers d'un répertoire sans le fichier "toto.xls". Merci d'avance!
Cordialement.

[jfontaine]

Bonjour,

Sur ce post, j'ai mis un exemple avec FSO

http://www.developpez.net/forums/d10...eurs-fichiers/

[kiki29]

Salut, sous VBE menu Outils/References Cocher Microsoft Scripting Runtime

Code :

1
2
3
4
5
6
7
8
 
Private Sub RecopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Scripting.FileSystemObject
 
    Set FSO = New Scripting.FileSystemObject
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub

Une fois la copie effectuée, adapter en rajoutant un kill du fichier non désiré ..... sur la Copie

ou

Code :

1
2
3
4
5
6
Private Sub RecopierDossier(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

PS : à lire http://warin.developpez.com/access/fichiers/

[HERVE57]

Merci pour les infos, mais le problème est que je ne peux pas copier le fichier que je ne veux pas car il est utilisé par un autre programme; si j'essaye de tout copier, la macro bug!

[jfontaine]

l'aide d'une macro, à copier tous les dossiers et fichiers d'un répertoire sans le fichier "toto.xls". Merci d'avance!

A cette lecture, on est bien ok, qu'on ne copie pas physiquement des fichiers dans un fichier excel.
Il s'agit bien de leurs chemin d'accès ?

[HERVE57]

En fait, je me suis mal expliqué! Le fichier d'exemple "Toto.xls" n'est en réalité, pas un fichier .xls, mais un fichier du logiciel Lotus, qu'il m'est impossible de copier par macro excel. C'est pour cela que je veux l'isoler et copier tous les autres fichiers et répertoires vers une autre destination.

[kiki29]

Salut,j'ai ceci qui trainait sur mon PC, améliorable sans doute et surement à adapter pour les chemins, copie récursive par défaut, sinon

Code :

    RecopierFichiers DossierACopier, False

DossierACopier = "C:\Test"
DossierDestination = ThisWorkbook.Path & "\" & "Destination"
sFichierANePasCopier = "Essai.xls"

Code :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
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
 
Dim DossierACopier As String
Dim DossierDestination As String
Dim CptF As Long, CptD As Long
Dim sFichierANePasCopier As String
 
Sub ReCopier_LB()
Dim Dep As Currency, Fin As Currency, Freq As Currency
    DossierACopier = "C:\Test"
    DossierDestination = ThisWorkbook.Path & "\" & "Destination"
    sFichierANePasCopier = "Essai.xls"
 
    CptF = 0
    CptD = 0
    QueryPerformanceCounter Dep
    RecopierFichiers DossierACopier, True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = "Terminé : " & CptD & " / " & CptF & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End Sub
 
Private Sub RecopierFichiers(ByVal sDossier As String, ByVal bInclureSousDossiers As Boolean)
Dim FSO As Object
Dim DossierSource As Object
Dim SousDossier As Object
Dim Fichier As Object, Pos As Integer, sNom As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DossierSource = FSO.GetFolder(sDossier)
 
    For Each Fichier In DossierSource.Files
        sNom = FSO.GetParentFolderName(Fichier)
        Pos = InStr(sNom, "\")
        sNom = Right$(sNom, Len(sNom) - Pos)
        If Pos > 0 Then
            CreationDossier (DossierDestination & "\" & sNom)
            If Fichier.Name <> sFichierANePasCopier Then
                CptF = CptF + 1
                FSO.CopyFile Fichier, DossierDestination & "\" & sNom & "\" & Fichier.Name, True
                Application.StatusBar = CptD & " / " & CptF
            End If
        End If
    Next Fichier
 
    If bInclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            Pos = InStr(SousDossier, "\")
            sNom = Right$(SousDossier, Len(SousDossier) - Pos)
            If Pos > 0 Then
                CreationDossier (DossierDestination & "\" & sNom)
                CptD = CptD + 1
                RecopierFichiers SousDossier.Path, True
            End If
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(ByVal sChemin As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sChemin, 0&)
End Sub

PS : je viens d'en déterrer un autre , à priori plus simple, qui reprend l'idée de Jérôme en construisant une liste récursive ou non des fichiers à partir d'un dossier racine.

Un bouton Selection Dossier Racine à affecter à la procédure SelectionDossierRacine
Une CheckBox baptisée Recur
Un bouton Selection Dossier Copies à affecter à la procédure SelectionDossierCopie
Un bouton Copier à affecter à la procédure Copie
La feuille recevant la liste avec un codename ShFichiers , voir http://www.developpez.net/forums/d92...cel/vba-bases/
Dans la cellule C1 apparaitra le dossier sélectionné via le bouton Selection Dossier Copies

Code :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
 
Option Explicit
 
Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
 
Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim r As Long
 
Sub Copie()
Dim LastRow As Long
Dim i As Long, sDossier As String, sFichier As String
Dim FSO As Object, Cpt As Long, Pos As Long, sDest As String
 
    LastRow = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
 
    Application.StatusBar = ""
    QueryPerformanceCounter Dep
    Cpt = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For i = 2 To LastRow
        sDossier = ShFichiers.Range("A" & i)
        sFichier = ShFichiers.Range("B" & i)
 
        Pos = InStr(sDossier & "\" & sFichier, "\")
        sDest = ShFichiers.Range("C1") & "\" & Mid$(sDossier, Pos + 1)
        CreationDossier sDest
 
        FSO.CopyFile sDossier & "\" & sFichier, sDest & "\" & sFichier, True
        Cpt = Cpt + 1
        Application.StatusBar = Cpt & " / " & LastRow - 1
    Next i
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " : " & Format(((Fin - Dep) / Freq), "0.00 s")
 
    Set FSO = Nothing
    ShFichiers.Range("D1").Select
End Sub
 
Private Sub CreationDossier(ByVal sChemin As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sChemin, 0&)
End Sub
 
Private Sub ListeFichiers(ByVal sChemin As String, bRecursif As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        NbFichiers = NbFichiers + 1
        sPath = sChemin & "\" & Fichier
        If Fichier <> ThisWorkbook.Name Then
            r = r + 1
            With ShFichiers
                .Cells(r, 1) = sChemin
                .Cells(r, 2) = Fichier
            End With
        End If
        Fichier = Dir$()
        Application.StatusBar = "Dossiers : " & NbDossiers & "  Fichiers : " & NbFichiers
    Loop
 
    If bRecursif Then
        For Each Dossier In Dossier.SubFolders
            NbDossiers = NbDossiers + 1
            ListeFichiers Dossier.Path, True
        Next Dossier
    End If
 
    Set FSO = Nothing
End Sub
 
Sub SelectionDossierCopie()
Dim sChemin As String
Dim FD As FileDialog
 
    sChemin = ThisWorkbook.Path & "\"
 
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .InitialFileName = sChemin
        .Title = "Sélectionner un Dossier pour la Copie"
        .AllowMultiSelect = False
        .ButtonName = "Sél. Dossier Copie"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            DoEvents
            ShFichiers.Range("C1") = .SelectedItems(1)
        End If
    End With
    ShFichiers.Range("D1").Select
    Set FD = Nothing
End Sub
 
Sub SelectionDossierRacine()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            ShFichiers.Range("A2:C" & Rows.Count).Clear
            Application.ScreenUpdating = False
            Application.StatusBar = ""
 
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
 
            DoEvents
            QueryPerformanceCounter Dep
            NbFichiers = 0: NbDossiers = 0: r = 1
 
            ListeFichiers .SelectedItems(1), ShFichiers.CheckBoxes("Recur").Value = 1
 
            Application.ScreenUpdating = True
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
            Application.StatusBar = "Dossiers : " & NbDossiers & "  Fichiers : " & NbFichiers & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
        End If
        ShFichiers.Range("D1").Select
    End With
End Sub

[HERVE57]

Bonjour et merci pour la réponse apportée à ma question! J'ai essayé de l'appliquer à mon problème, mais cela semble assez long, et de plus mon fichier n'a pas tjrs le même nom!! Par contre le dossier qui contient ce fichier à tjrs le même nom ("Workspace"); ce qui me fait dire qu'il serait peut-être finalement plus interressant de faire en sorte de copier tous les dossiers et sous dossiers sauf le dossier "Workspace"! Avez-vous un code pour cela? Merci d'avance et...bonne année!

[kiki29]

Salut, les 2 avec un fichier et un dossier à ne pas copier, à adapter et simplifier

Code :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
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
 
Dim DossierACopier As String
Dim DossierDestination As String
Dim CptF As Long, CptD As Long
Dim sDossierANePasCopier As String
Dim sFichierANePasCopier As String
 
Sub ReCopier_LB()
Dim Dep As Currency, Fin As Currency, Freq As Currency
    DossierACopier = "C:\Test"
    DossierDestination = ThisWorkbook.Path & "\" & "Destination"
    sFichierANePasCopier = "Essai.pdf"
    sDossierANePasCopier = "fichiers"
 
    CptF = 0
    CptD = 0
    QueryPerformanceCounter Dep
    RecopierFichiers DossierACopier, True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = "Terminé : " & CptD & " / " & CptF & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
End Sub
 
Private Sub RecopierFichiers(ByVal sDossier As String, ByVal bInclureSousDossiers As Boolean)
Dim FSO As Object
Dim DossierSource As Object
Dim SousDossier As Object
Dim Fichier As Object, Pos As Integer, sNom As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DossierSource = FSO.GetFolder(sDossier)
 
    For Each Fichier In DossierSource.Files
        sNom = FSO.GetParentFolderName(Fichier)
        Pos = InStr(sNom, "\")
        sNom = Mid$(sNom, Pos + 1)
        If Fichier.Name <> sFichierANePasCopier Then
            If Pos > 0 Then
                CreationDossier (DossierDestination & "\" & sNom)
                CptF = CptF + 1
                FSO.CopyFile Fichier, DossierDestination & "\" & sNom & "\" & Fichier.Name, True
                Application.StatusBar = CptD & " / " & CptF
            End If
        End If
    Next Fichier
 
    If bInclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            Pos = InStr(SousDossier, "\")
            sNom = Mid$(SousDossier, Pos + 1)
            If SousDossier.Name <> sDossierANePasCopier Then
                If Pos > 0 Then
                    CreationDossier (DossierDestination & "\" & sNom)
                    CptD = CptD + 1
                    RecopierFichiers SousDossier.Path, True
                End If
            End If
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(ByVal sChemin As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sChemin, 0&)
End Sub

[HERVE57]

Merci pour votre disponibilité et réactivité! La solution me convient parfaitement!
Cordialement.