Problème sur une boucle For Each

Version imprimable

Bonjour à tous,

Je suis entrain de faire une macro qui doit enregistrer un fichier à un autre endroit sous un nom différent, supprimer les onglets qui ont la cellule A2 vide, et ensuite appliquer une certaine mise en page sur chaque onglet. Je suis passée par une boucle For Each. Le code fonctionne très bien lorsque le fichier ne contient qu'un seul onglet, mais dès qu'il y en a plusieurs, le code fonctionne sur le premier onglet mais au lieu de passer à l'onglet d'après il refait une boucle de mise en page sur le même onglet.

Je vous laisse mon code pour que vous puissiez regarder où je me suis trompée.

Merci beaucoup

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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
Workbooks.Open Filename:=ChSFI
ActiveWorkbook.RefreshAll
 
'Enregistre une copie du fichier SFI avec la date du mensuel
date_analyse = Range("A2")
date_analyse = Format(date_analyse, "yyyy mm dd")
nom_fichier = date_analyse & " Mensuel SFI.xlsm"
 
If Fichierexiste(cheminsave & nom_fichier) Then   'on appelle la fonction fichierexiste
        reponse = MsgBox("Attention le fichier " & nom_fichier & " existe deja, voulez vous le remplacer", vbYesNo)
 
            If reponse = vbYes Then
 
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:= _
            cheminsave & nom_fichier
 
             Else
 
            Application.Dialogs(xlDialogSaveAs).Show "Copie de " & cheminsave & nom_fichier
 
             End If
 
        Else ' si le fichier exsite pas fileexist = false
 
             ActiveWorkbook.SaveAs Filename:= _
            cheminsave & nom_fichier
 
    End If
 
'Supprime les onglets qui sont vides
Application.DisplayAlerts = False
    For Each WS In Sheets
        NbOnglet = ActiveWorkbook.Sheets.Count
 
            If NbOnglet > 1 Then
 
            If Range("B4") = "" Then
                WS.Delete
            Else
           End If
 
            Else
            End If
 
'Ajoute la colonne "A:A"
    Columns("A:A").Select
    Range("A1").Activate
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Groupement des colonnes
    Columns("C:C").Select
    Selection.Columns.Group
    Columns("G:H").Select
    Selection.Columns.Group
    Columns("M:M").Select
    Selection.Columns.Group
    Columns("O:O").Select
    Selection.Columns.Group
    Columns("R:R").Select
    Selection.Columns.Group
    Columns("AB:AF").Select
    Selection.Columns.Group
    Columns("AM:AP").Select
    Selection.Columns.Group
    Columns("AR:AY").Select
    Selection.Columns.Group
 
 
'Ajoute la ligne Client Identification
 
 
    Rows("1:2").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
    Range("B2:F2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("G2:L2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Client Identification"
    Range("M2:AE2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Anomaly Description"
    Range("AF2:AP2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Anomaly Analysis"
    Range("AQ2:BB2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Additional Information"
 
 
'Format aux couleurs CACIB de l'entete
    Range("B2:BB3").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5733632
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
 
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
 Next

Fais sortir yon NbOnglet de la boucle

sinon, Commence par réorganiser ton code, par exemple

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
Dim Nom_Fichier As String, Suff As String
Dim Wbk As Workbook
Dim DAnalyse As Date
Dim Ws As Worksheet
Dim Reponse As Long
Dim NbOnglet As Integer
 
'................début macro
 
Set Wbk = Workbooks.Open(ChSFI)
With Wbk
    .RefreshAll
 
    Date_Analyse = .Worksheets(1).Range("A2")
    Nom_Fichier = Format(Date_Analyse, "yyyy mm dd") & " Mensuel SFI.xlsm"
 
    If Fichierexiste(CheminSave & Nom_Fichier) Then
        Reponse = MsgBox("Attention le fichier " & Nom_Fichier & " existe deja, voulez vous le remplacer", vbYesNo)
        If Reponse = vbNo Then Suff = "Copie de "
    End If
 
    Application.DisplayAlerts = False
    .SaveAs Filename:=Suff & CheminSave & Nom_Fichier
    Application.DisplayAlerts = False
 
    NbOnglet = .Sheets.Count
    For Each Ws In .Worksheets
        If NbOnglet > 1 Then
            If Ws.Range("B4") = "" Then Ws.Delete
        End If
    Next Ws
 
    '.la suite
End With
Set Wbk = Nothing

bonjour,

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
 
Sub test()
Workbooks.Open Filename:=ChSFI
ActiveWorkbook.RefreshAll
 
'Enregistre une copie du fichier SFI avec la date du mensuel
date_analyse = Range("A2")
date_analyse = Format(date_analyse, "yyyy mm dd")
nom_fichier = date_analyse & " Mensuel SFI.xlsm"
 
If Fichierexiste(cheminsave & nom_fichier) Then   'on appelle la fonction fichierexiste
        reponse = MsgBox("Attention le fichier " & nom_fichier & " existe deja, voulez vous le remplacer", vbYesNo)
 
            If reponse = vbYes Then
 
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:= _
            cheminsave & nom_fichier
 
             Else
 
            Application.Dialogs(xlDialogSaveAs).Show "Copie de " & cheminsave & nom_fichier
 
             End If
 
        Else ' si le fichier exsite pas fileexist = false
 
             ActiveWorkbook.SaveAs Filename:= _
            cheminsave & nom_fichier
 
    End If
 
'Supprime les onglets qui sont vides
Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
        If SupprierSheet(Sheets(i)) = False Then
            'Ajoute la colonne "A:A"
            Sheets(i).Range("A1").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            'Groupement des colonnes
            GroupementDesCcolonnes Sheets(i)
            'Ajoute la ligne Client Identification
            Sheets(i).Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            miseEnPage Sheets(i).Range("B2:F2")
            miseEnPage Sheets(i).Range("G2:L2")
            Sheets(i).Range("G2") = "Client Identification"
            miseEnPage Sheets(i).Range("M2:AE2")
            Sheets(i).Range("M2") = "Anomaly Description"
            miseEnPage Sheets(i).Range("AF2:AP2")
            Sheets(i).Range("AF2") = "Anomaly Analysis"
             miseEnPage Sheets(i).Range("AQ2:BB2")
            Sheets(i).Range("AQ2") = "Additional Information"
 
            'Format aux couleurs CACIB de l'entete
            With Sheets(i).Range("B2:BB3").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 5733632
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
                With Sheets(i).Range("B2:BB3").Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
             Sheets(i).Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
        End If
 Next
End Sub
Sub GroupementDesCcolonnes(Ws As Worksheet)
Ws.Columns("C:C").Columns.Group
    Ws.Columns("G:H").Columns.Group
    Ws.Columns("M:M").Columns.Group
    Ws.Columns("O:O").Columns.Group
    Ws.Columns("R:R").Columns.Group
    Ws.Columns("AB:AF").Columns.Group
    Ws.Columns("AM:AP").Columns.Group
    Ws.Columns("AR:AY").Columns.Group
End Sub
 
Function SupprierSheet(Ws As Worksheet) As Boolean
 If ActiveWorkbook.Sheets.Count > 1 And Trim("" & Ws.Range("B4")) = "" Then Ws.Delete: SupprierSheet = True
End Function
Sub miseEnPage(R As Range)
 With R
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    R.Merge
End Sub

27/11/2014, 09h14
nanoo79

Bonjour Mercatog et Rdurupt, ,

Merci pour votre aide. cela fonctionne très bien!