Discussion :

[Rémi Fournier]

Bonjour et merci à l'avance de me répondre.

J'ai créé il y a quelque années une macro qui permettait de lire un répertoire et de le recopier en incriminent son nom. Le but était de créer des répertoires identiques avec seulement le nom qui changeait , Bien maintenant elle ne fonctionne pas, j'ai beau lire sur tout les forum et je suis planté à tout coup cela doit être conséquent de mon age.

Voici celle macro et si quelqu'un a un idée sa me rajeunirais:

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
Sub creationrepertoire_AGE()
    Dim I, fichier As Integer
    Dim fso As FileSystemObject
    Dim F As Object
    Dim PATH, NOUVEAUFICHIER, STATE As String
    Dim NOMRÉPERTOIRE, STRINGFILE, TEMPSTR As String
 
PATH = "c:\DETRUIT\"
 
    Set fso = New FileSystemObject
 
    For I = 1 To 100
    NOMRÉPERTOIRE = Format(I, "000")
    fso.COPYFOLDER PATH & "!RépertoireModèle", PATH & NOMRÉPERTOIRE
 
    With Application.FileSearch
    .SearchSubFolders = True
    .MatchAllWordForms = True
    .LookIn = PATH & NOMRÉPERTOIRE
    .FileType = msoFileTypeAllFiles
 
    STRINGFILE = "*XXX*"
 
    .FileName = STRINGFILE
    .Execute
 
    For fichier = 1 To .FoundFiles.Count
 
           TEMPSTR = .FoundFiles(fichier)
 
Name TEMPSTR As Replace(TEMPSTR, "XXX", NOMRÉPERTOIRE, 1)
 
    Next fichier
 
End With
 
  Next
 
End Sub

[Invité]

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
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
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe_RD(Repertoires As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(Repertoires) Then Repertoires_Existe_RD = True
Set FSO = Nothing
End Function
 
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires_RD(NewRepertoires As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim T
Dim R As String
Dim I As Long
R = ""
T = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(T)
    If Trim("" & T(I)) <> "" Then
        R = R & Trim("" & T(I)) & "\"
        If Repertoires_Existe_RD(R) = False Then FSO.CreateFolder R
    End If
Next
Set FSO = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires_RD(Source As String, Destination As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFolder Source, Destination, True
Set FSO = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Sub Deplace_Repertoire_RD(Source As String, Destination As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFolder Source, Destination
Set FSO = Nothing
End Sub
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire_RD(DelRepertoire As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder DelRepertoire, True
Set FSO = Nothing
End Sub
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier_RD(Source As String, Destination As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile Source, Destination, True
Set FSO = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier_RD(Source As String, Destination As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Source, Destination
Set FSO = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier_RD(DelFichier As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile DelFichier, True
Set FSO = Nothing
End Sub