Appliquer une macro sur plusieurs fichiers Excel contenus dans un même répertoire [Résolu]

[tibss]

Bonjour,

Je me permets de vous contacter car j'ai un petit soucis : j'aimerais appliquer une macro de mise en forme sur l'ensemble des fichiers contenus dans un même répertoire (le nom des fichiers peut évoluer, je ne peux donc pas sélectionner et ouvrir nominativement les fichiers). Vous pourrez trouver ci-dessous le code que j'ai réalisé. Toute la partie message box, input box fonctionne. Par contre, je ne sais pas comment appliquer ma macro sur l'ensemble des fichiers du répertoire. Il s'agit de la partie grisée en commentaire. Je souhaite appeler ma foncontion à travers "Call mise_en_forme".

Ma fonction mise en forme permet de copier différentes colonnes des fichiers (dont je ne connais pas les noms mais qui se trouvent dans mon répertoire) et de les coller dans le document Excel sur lequel se trouve ma macro. Ma macro de mise en forme est disponible en dessous du premier code.


Code :

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
Dim Chemin As String
Sub Appli_Boutton()
Chemin = InputBox("Entrez l'arborescence du répertoire contenant les fichiers sur lesquels vous souhaitez effectuer les retraitements")
 
'Tant que le chemin du répertoire n'est pas renseigné, redemander le lien du chemin
If Chemin = "" Then
    MsgBox "Vous n'avez pas indiqué de repertoire d'entrée", vbCritical, "Erreur"
        Do While Chemin = ""
        Chemin = InputBox("Entrez l'arborescence du répertoire contenant les fichiers sur lesquels vous souhaitez effectuer les retraitements")
        If Chemin = "" Then
        Reponse = MsgBox("Souhaitez-vous mettre en forme des fichiers?", vbYesNo + vbQuestion)
            If Reponse = vbNo Then Exit Sub
        End If
    Loop
End If
 
If Not (RepertoireExiste(Chemin)) Then         'permet de savoir si le repertoire existe'
MsgBox "Le repertoire d'entrée n'existe pas", vbCritical, "Erreur"
    Do While RepertoireExiste(Chemin) = False
    Chemin = InputBox("Entrez l'arborescence du répertoire contenant les fichiers sur lesquels vous souhaitez effectuer les retraitements")
        If Not (RepertoireExiste(Chemin)) Then
            Reponse = MsgBox("Souhaitez-vous mettre en forme des fichiers?", vbYesNo + vbQuestion)
            If Reponse = vbNo Then Exit Sub
        End If
    Loop
End If
 
'Parcours les fichiers contenu dans le dossier d'entrée'
 
'Fichier = Dir(Chemin & "\*")
'Do While Fichier <> ""
'    Application.ScreenUpdating = False 'Pour que l'écran ne soit pas mis à jour
'        Workbooks.Open (Chemin & "\" & Fichier)
'        Call mise_en_forme()'
'    End If
 
'   Fichier = Dir()
'Loop
 
MsgBox Chemin
 
End Sub
 
'Fonction permettant de savoir si le repertoire existe'
Function RepertoireExiste(Nom As String) As Boolean
On Error Resume Next
RepertoireExiste = GetAttr(Nom) And vbDirectory
End Function

Code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub mise_en_forme()
 
Set Entree = Workbooks.Open(Filename:="C:\Les différents fichiers Excel se trouvant dans le répertoire")
Set Import = ThisWorkbook.Sheets("Import") 'Le fichier dans lequel je souhaite récupérer les différentes colonnes, et qui contient ma macro
 
i = 1
For Each cellule In Import.Range(Import.Cells(1, 2), Import.Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then i = i + 1
Next
 
j = 1
For Each cellule In Entree.Sheets("sheet1").Range(Entree.Sheets("sheet1").Cells(1, 2), Entree.Sheets("sheet1").Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then j = j + 1
Next
 
Entree.Sheets("sheet1").Columns(j).Copy Import.Cells(1, i + 1)
 
End Sub

Est-ce que quelqu'un pourrait m'aider sur la question s'il vous plaît ?
Je reste à votre disposition pour toutes informations complémentaires.

Merci d'avance,

Bien cordialement,

Tibss

[tibss]

Pour être un peu plus précis, j'ai un chemin de répertoire qui est par exemple :

Code :

"C:\Documents and Settings\...\Desktop\RépertoireContenantFichiers

je souhaite appliquer à l'ensemble des fichiers de ce répertoire une macro. Je ne sais pas trop comment faire, quelqu'un a-til une idée ?

Merci d'avance !

(voici le code sur lequel j'ai commencé à plencher, mais je ne sais pas trop comment incrémenter les fichiers...)

Code :

1
2
3
4
5
6
7
8
9
'Fichier = Dir(Chemin & "\*")
'Do While Fichier <> ""
'    Application.ScreenUpdating = False 'Pour que l'écran ne soit pas mis à jour
'        Workbooks.Open (Chemin & "\" & Fichier)
'        Call mise_en_forme()'
'    End If
 
'   Fichier = Dir()
'Loop

ma fontion mise en forme est la suivante :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
Sub mise_en_forme()
 
Set Entree = Workbooks.Open(Filename:="C:\Les différents fichiers Excel se trouvant dans le répertoire")
Set Import = ThisWorkbook.Sheets("Import") 'Le fichier dans lequel je souhaite récupérer les différentes colonnes, et qui contient ma macro
 
i = 1
For Each cellule In Import.Range(Import.Cells(1, 2), Import.Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then i = i + 1
Next
 
j = 1
For Each cellule In Entree.Sheets("sheet1").Range(Entree.Sheets("sheet1").Cells(1, 2), Entree.Sheets("sheet1").Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then j = j + 1
Next
 
Entree.Sheets("sheet1").Columns(j).Copy Import.Cells(1, i + 1)
 
End Sub

[Godzestla]

Bonjour,

qqchose du genre :

Code :

1
2
3
4
5
6
7
8
'Fichier = Dir(Chemin & "\*")
Do While Fichier <> ""
    Application.ScreenUpdating = False 'Pour que l'écran ne soit pas mis à jour
        Call mise_en_forme(fichier)
    End If
    
   Fichier = Dir()
Loop

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
Sub mise_en_forme(fichier as string)
 
Set Entree = Workbooks.Open(Filename:=fichier)
Set Import = ThisWorkbook.Sheets("Import") 'Le fichier dans lequel je souhaite récupérer les différentes colonnes, et qui contient ma macro
 
i = 1
For Each cellule In Import.Range(Import.Cells(1, 2), Import.Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then i = i + 1
Next
 
j = 1
For Each cellule In Entree.Sheets("sheet1").Range(Entree.Sheets("sheet1").Cells(1, 2), Entree.Sheets("sheet1").Cells(1, 2).End(xlToRight))
If cellule.Value <> "" Then j = j + 1
Next
 
Entree.Sheets("sheet1").Columns(j).Copy Import.Cells(1, i + 1)

entree.save
entree.close

set entree = nothing
set import = nothing 
 
End Sub

Attention à ne jamais oublier les set = Nothing sinon ton code devient très vite.... planté.

Bonne chance. Désolé, je n'ai pas plus de temps.

------------------- Edit
1 dernière chose.

regarde dans l'aide de Dir.

Ton utilisation ne limite pas la sélection aux fichiers excel alors tu risque de planter à l'open !!!!

[tibss]

Merci beaucoup pour cette aide ! Cela fonctionne parfaitement !