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

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

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

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

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

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

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 :

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

[Godzestla]

Bonjour,

qqchose du genre :

Code :

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

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 :

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

[choji5]

Pardon de relancer le sujet aussi longtemps après mais je fais exactement la même chose que vous, j'ouvre un par un les fichiers d'un répertoire
Ensuite je veux pendant que chaque fichier est ouvert, aller ouvrir un autre fichier dans un autre répertoire ou seul l'année du fichier sera différente.

Ceci est bon normalement sauf que je veux tester si le fichier existe d'abord et je ne peut pas réutiliser la fonction Dir(Chemin) car sinon mon application s'arrête ensuite (car Dir n'est pas itérative comme tu l'as dis je pense).

Pardon si je m'exprime mal, et merci d'avance si vous pouvez m'aider.

Merci

[VBuzze]

Bonjour,
Voilà le Sub que j'ai créé, il adapte les données d'une première feuille (source) dans un format imposé sur une seconde feuille "Results" ainsi générée :

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
 
Sub tr()
    Dim i As Integer
    Dim j As Integer
    Dim a As String
    Dim b As String
    Dim c As Integer
    Sheets.Add.Name = "Results"
    a = Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B16")
    j = 1
    c = 1
    For i = 15 To 1000
    If Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i).Font.Bold Then
        Application.ThisWorkbook.Worksheets("Results").Range("A" & j) = a
        Application.ThisWorkbook.Worksheets("Results").Range("B" & j) = c
        Application.ThisWorkbook.Worksheets("Results").Range("C" & j) = Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i)
        c = c + 1
        j = j + 1
    ElseIf Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i) = "" Then
        Exit For
        End If
        Next
    For i = 15 To 1000
        If Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i).Font.Bold Then
            b = Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i)
        ElseIf Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i) <> "" Then
            Application.ThisWorkbook.Worksheets("Results").Range("A" & j) = a
            Application.ThisWorkbook.Worksheets("Results").Range("B" & j) = b
            Application.ThisWorkbook.Worksheets("Results").Range("C" & j) = Application.ThisWorkbook.Worksheets("VK_Preisliste").Range("B" & i)
            j = j + 1
        Else
            Exit For
        End If
        Next
    ActiveWorkbook.Worksheets("Results").Activate
    ActiveWindow.Zoom = 30
    Worksheets("Results").Range("A1:C500").Replace Chr(10), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(13), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(11), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(124), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(0), Chr(32)
    Worksheets("Results").Range("A1:C500").Columns.AutoFit
    Worksheets("Results").Range("A1:C500").Rows.AutoFit
    Worksheets("Results").Range("A1:C500").Replace Chr(10), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(13), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(11), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(124), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(0), Chr(32)
    Worksheets("Results").Range("A1:C500").Columns.AutoFit
    Worksheets("Results").Range("A1:C500").Rows.AutoFit
    Worksheets("Results").Range("A1:C500").Replace Chr(10), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(13), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(11), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(124), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(0), Chr(32)
    Worksheets("Results").Range("A1:C500").Columns.AutoFit
    Worksheets("Results").Range("A1:C500").Rows.AutoFit
    Worksheets("Results").Range("A1:C500").Replace Chr(10), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(13), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(11), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(124), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(0), Chr(32)
    Worksheets("Results").Range("A1:C500").Columns.AutoFit
    Worksheets("Results").Range("A1:C500").Rows.AutoFit
    Worksheets("Results").Range("A1:C500").Replace Chr(10), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(13), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(11), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(124), Chr(32)
    Worksheets("Results").Range("A1:C500").Replace Chr(0), Chr(32)
    Worksheets("Results").Range("A1:C500").Columns.AutoFit
    Worksheets("Results").Range("A1:C500").Rows.AutoFit
End Sub

Je souhaiterais pouvoir le faire tourner sur un ensemble de fichiers contenus dans un même dossier, comment faire ?
Merci d'avance,

[seb2048]

bonjour,

je suis debutant sur excel,

j ai la mission de realiser les étiquettes produits dexcriptif et prix pour 43 magasins dc beaucoup beaucoup d etiquettes
j ai un fichier de base que j ai modifie avec une macro qui m apporte les prix ttc les remises le classement par famille etc et ca marche bien mais j y passe trop de temps environ 3 fichiers xls par magasin. je lance ma macro fichier par fichier et j en registre j y passe 3jours avec le publipostage

j ai lu les precedents posts mais il y a plein de trucs que je ne saisi pas il me manque des etapes

j aimerais appliquer une macro que j ai peniblement realisee à un ensemble de fichiers se trouvant dans un meme repertoire sans avoir ouvrir chaque fois le fichier xls et lui appliquer la macro de mon classeur personnel de macro

est ce que qqun pourrait me decrire etape par etape ce que je dois faire

merci d avance pour votre aide