Filtre automatique qui ne s'active pas

**Lyndils** · 01/07/2015, 15h13

Bonjour,

J'ai un petit soucis concernant le filtre que je code sur vba, celui devrait fonctionné, mais pour je ne sais quel raison il déconne.

Voici le 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
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
Sub Récupération_Des_Données()
        Dim Chemin As String, Fichier As String, Nom As String
        Dim NewLig As Long, N As Long
        Dim Repertoire As FileDialog
        Dim Wb As Workbook
        Dim Plage
 
        Application.ScreenUpdating = False
        Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
        Repertoire.Show
        Chemin = Repertoire.SelectedItems(1)
 
        Fichier = Dir(Chemin & "\" & "*.xls")
        Do While Fichier <> ""
            Set Wb = Workbooks.Open(Chemin & "\" & Fichier)
            With Wb.Worksheets(1)
                N = .Cells(.Rows.Count, 1).End(xlUp).Row
                Plage = .Range("A2").Resize(N, 7)
 
            End With
 
            Nom = Wb.Name
            Wb.Close False
            Set Wb = Nothing
 
            With ThisWorkbook.Worksheets("Export Données")
                NewLig = .Cells(.Rows.Count, 10).End(xlUp).Row + 1
                .Range("D" & NewLig).Resize(N, 7).Value = Plage
                .Range("A" & NewLig).Resize(N) = Mid(Nom, 1, 14)
                .Range("B" & NewLig).Resize(N) = Mid(Nom, 16, 8)
                .Range("C" & NewLig).Resize(N) = Mid(Nom, 27, 3)
            End With
            Fichier = Dir()
         Loop
 
                ' Remplacer points en virgules
                With ThisWorkbook.Worksheets("Export Données")
                Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
                :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                End With
 
                ' Centrer toutes les cases
 
                Cells.Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                End With
 
                ' Remplacement mots critères pour Détourage
 
                Cells.Replace What:="c ", Replacement:="CONTOUR ", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
 
                Cells.Replace What:="PCT", Replacement:="CONTOUR ", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
 
 
 
                '    /FILTRES/
 
                ' Activé Filtre
 
 
                ' Filtre Perçage
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Perçage")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                ' Filtre Détourage
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Détourage")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=6, Criteria1:="V,G,"
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                ' Filtre Forme
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Forme")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                'Filtre Planéité
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Planéité")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$60714").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                'Filtre Localisation
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Localisation")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$41101").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
    Sheets("Perçage").Select
            Columns("I:I").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Recapitulatif").Select
            Range("J1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Sheets("Détourage").Select
            Columns("G:G").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Recapitulatif").Select
            Range("K1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Sheets("Forme").Select
            Columns("G:G").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Recapitulatif").Select
            Range("L1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Sheets("Planéité").Select
            Columns("G:G").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Recapitulatif").Select
            Range("M1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Sheets("Localisation").Select
            Columns("G:G").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Recapitulatif").Select
            Range("N1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
   'Perçage modif nombre
Columns("J:J").Select
    Selection.TextToColumns Destination:=Range("J1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
 
    'Détourage modif nombre
 Columns("K:K").Select
    Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
 
    'Forme modif nombre
    Columns("L:L").Select
    Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
 
    'Planéité modif nombre
    Columns("M:M").Select
    Selection.TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
 
    'Localisation modif nombre
    Columns("N:N").Select
    Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
 
 
         Set Repertoire = Nothing
        MsgBox "Récupération des données : Succès!"
        End Sub

Plus précisément, le code des filtre est:

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
 '    /FILTRES/
 
                ' Activé Filtre
 
 
                ' Filtre Perçage
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Perçage")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                ' Filtre Détourage
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Détourage")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=6, Criteria1:="V,G,"
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                ' Filtre Forme
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Forme")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$1048576").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                'Filtre Planéité
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Planéité")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$60714").AutoFilter Field:=7, Criteria1:="<>"
                End With
 
                'Filtre Localisation
                Selection.AutoFilter
                With ThisWorkbook.Worksheets("Localisation")
                Selection.AutoFilter
                ActiveSheet.Range("$A$1:$XFD$41101").AutoFilter Field:=7, Criteria1:="<>"
                End With

De plus j'aimerai qu'il copie colonne les colonnes de chaque feuille où le filtre est présent est les colle dans la première page sans les cases vides.

Merci d'avance pour vos réponses!

Amicalement,
Lyndils

**parmi** · 02/07/2015, 22h03

Bonjour,

tu mets pas mal de Autofilter.
Une fois ça les active, une fois ça les désactive, mais où en es-tu exactement ? es-tu certain que c'est le bon moment d'activer ou non ?

La meilleure façon de procéder, je pense, c'est d'éliminer le filtre et le reconstruire

Code :

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

1
2
3
4
5
                ' Filtre Perçage
                With ThisWorkbook.Worksheets("Perçage")
                    .AutofilterMode = False
                    .Rows(1).AutoFilter Field:=7, Criteria1:="<>"
                End With

**joe.levrai** · 02/07/2015, 23h38

Bonjour,

qu'est ce qui ne marche pas exactement ? plantage VBA ? aucun résultat ? autre ?

en attendant, une proposition pour optimiser un peu ton code, je n'ai pas pu tester vu le contexte lourd à reproduire, regarde si ça peut te donner des idées, y'a sûrement plus simple encore

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Sub Récupération_Des_Données()
Dim Chemin As String, Fichier As String, Nom As String
Dim NewLig As Long, N As Long
Dim Repertoire As FileDialog
Dim Wb As Workbook
Dim Plage As Range
Dim i As Long
 
Dim TabSource()
Dim TabDest()
Dim ListeFeuil()
TabSource = Array(".", "c ", "PCT")
TabDest = Array(",", "CONTOUR ", "CONTOUR ")
ListeFeuil = Array("Perçage", "Détourage", "Forme", "Planéité", "Localisation")
 
 
Application.ScreenUpdating = False
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
Chemin = Repertoire.SelectedItems(1)
 
Fichier = Dir(Chemin & "\" & "*.xls")
Do While Fichier <> ""
    Set Wb = Workbooks.Open(Chemin & "\" & Fichier)
    With Wb
        With .Worksheets(1)
            N = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set Plage = .Range("A2").Resize(N, 7)
        End With
 
        Nom = .Name: .Close False
        Set Wb = Nothing
    End With
 
    With ThisWorkbook.Worksheets("Export Données")
        NewLig = .Cells(.Rows.Count, 10).End(xlUp).Row + 1
        .Range("D" & NewLig).Resize(N, 7).Value = Plage.Value
        .Range("A" & NewLig).Resize(N) = Mid(Nom, 1, 14)
        .Range("B" & NewLig).Resize(N) = Mid(Nom, 16, 8)
        .Range("C" & NewLig).Resize(N) = Mid(Nom, 27, 3)
    End With
    Fichier = Dir()
Loop
 
' toutes les cellules de la feuille
With ThisWorkbook.Worksheets("Export Données").Cells
    'alignement
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
 
    ' boucle pour les remplacements de valeurs
    For i = LBound(TabSource) To UBound(TabSource)
        .Replace What:=TabSource(i), _
          Replacement:=TabDest(i), _
               LookAt:=xlPart, _
          SearchOrder:=xlByRows, _
            MatchCase:=False, _
         SearchFormat:=False, _
        ReplaceFormat:=False
    Next i
End With
 
' boucle sur les feuilles
For i = LBound(ListeFeuil) To UBound(ListeFeuil)
    With ThisWorkbook.Worksheets(ListeFeuil(i))
        ' désactivation des filtres
        .AutoFilterMode = False
        ' si feuille Détourage, on filtre la colonne F
        If i = 2 Then .Cells(1, 1).AutoFilter Field:=6, Criteria1:="V,G,"
        ' filtre sur la colonne G
        .Cells(1, 1).AutoFilter Field:=7, Criteria1:="<>"
        ' si feuille Perçage = copie colonne I || sinon copie de la colonne G
        If i = 0 Then .Columns(9).Copy Else .Columns(7).Copy
    End With
 
    ' sur la feuille de récap'
    With ThisWorkbook.Worksheets("Recapitulatif")
        ' collage des valeurs dans les colonnes J à M
        .Cells(1, i + 10).PasteSpecial Paste:=xlPasteValues
 
        .Columns(i + 10).TextToColumns _
                    Destination:=Cells(1, i + 10), _
                       DataType:=xlDelimited, _
                  TextQualifier:=xlDoubleQuote, _
                      FieldInfo:=Array(1, 1), _
           TrailingMinusNumbers:=True
    End With
Next i
 
Set Repertoire = Nothing
MsgBox "Récupération des données : Succès!"
End Sub

Filtre automatique qui ne s'active pas

Macros et VBA Excel

Discussions similaires

Partager

Partager