Discussion :

[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 contion à 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 :

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
 
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 :

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
 
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]

Merci, c'est résolu