Discussion :

[aalex_38]

Bonjour,

J'ai un fichier avec un filtre sur chaque colonne.

Je veux dans mon programme récupérer les différents éléments présents dans ma colonne P.

Donc récupérer la même liste que lorsque l'on clique sur le bouton en regard de la colonne filtrée.

Pour l'instant j'ai mis en "dur" .

Le code actuel :

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
Sub compte()
Dim sheetAno As String, sheetRes As String, NomFichier As String

shano = "ANO"
SHres = "Résultats"
NomFichier = "TEST"

' Recopie de l'onglet du fichier dans ce classeur
Workbooks(NomFichier).Sheets _
(shano).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        
' Creation d'un nouvel onglet
Add_sheet SHres, True
    
Dim F2 As Worksheet
Set F2 = Worksheets(SHres)

'Ici les différentes erreurs possibles issues de la colonne P du fichier test
Dim Tableau(1 To 11) As String
Tableau(1) = 112
Tableau(2) = 180
Tableau(3) = 181
Tableau(4) = 192
Tableau(5) = 201
Tableau(6) = 204
Tableau(7) = 231
Tableau(8) = 243
Tableau(9) = 244
Tableau(10) = 300
Tableau(11) = 450

For i = LBound(Tableau) To UBound(Tableau)
    F2.Cells(i, 1) = Tableau(i)
    F2.Cells(i, 2) = compte_erreur(F2.Cells(i, 1), shano)
Next

End Sub

[SilkyRoad]

bonsoir

Tu peux identifier la plage de cellules visible dans la colonne p et boucler sur ces cellules :

Code :

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

1
2
3
4
5
6
'Identification de la plage visible
Dim Plage As Range
 
Set Plage = Feuil1.AutoFilter.Range.Columns(16). _
    SpecialCells(xlCellTypeVisible).Cells
MsgBox Plage.Address

bonne soirée
michel

[aalex_38]

Re

Je suis peut être sur un piste, comme je suis sur que dans cette colonne les nombres ne peuvent aller que de 0 à 999, il me suffit peut être de faire une boucle et de rechercher dans la colonne si le numéro existe.

Si vous avez des suggestions, une idée, quelque chose de plus élégant je suis preneur

Merci SilkyRoad, c'est ce que je vais faire.

[aalex_38]

J'ai mis le code en place même s'il est un peu long (1 minute et demi pour un fichier de 10 000 lignes en entrée, avec 11 types d'erreurs différentes).

Comme la colonne filtrée ne peut contenir que des chiffres de 1 à 999 , j'ai fait une boucle pour traiter tous les cas trouvés. Ce n'est pas tellement optimisé mais bon ça marche très bien. je vais essayer de faire un code un peu plus rapide en attendant 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
Private Sub Boucle_recu_reponse()
 
' ------------------------------------------------------------------------------------------- '
' Ouverture des fichiers recu et reponse
' ------------------------------------------------------------------------------------------- '
Dim Win As Workbook
Dim W1 As Workbook, NomW1 As String, CheminW1 As String
Dim W2 As Workbook, NomW2 As String, cheminW2 As String
Dim boul2 As Boolean, boul1 As Boolean
 
NomW1 = "yyy.xls" 'Fichier réponse
NomW2 = "zzz.xls" ' Fichier reçu
 
CheminW1 = "x:\xxx\Dossier reponse"
cheminW2 = "x:\xxx\xxx\Dossier recu"
 
For Each Win In Workbooks
 
    If Win.Name = NomW1 Then boul1 = True:
    If Win.Name = NomW2 Then boul2 = True:
 
Next
 
If Not boul1 Then
Workbooks.Open Filename:=CheminW1 & Application.PathSeparator & NomW1
End If
 
If Not boul2 Then
Workbooks.Open Filename:=cheminW2 & Application.PathSeparator & NomW2
End If
 
Set W1 = Workbooks(NomW1)
Set W2 = Workbooks(NomW2)
 
' ------------------------------------------------------------------------------------------- '
Dim NumErr As Long
 
 
' Filtrer sur le numéro
Dim sHAno As String, sHres As String
Const LibErr As String = "Err"
 
sHAno = "www.ANO"
sHres = "Résultats "
sHerr = LibErr
' ------------------------------------------------------------------------------------------- '
' Si l'onglet des anos existe le supprimer, resultat aussi avant la boucle
' ------------------------------------------------------------------------------------------- '
Dim Max As Integer
For i = Sheets.Count To 1 Step -1
 'Suppression des onglets recu et reponse
 'Suppression des onglets erreurs
    If Sheets(i).Name = sHAno Or Sheets(i).Name = sHres Or Mid(Sheets(i).Name, 1, 3) = Mid(sHerr, 1, 3) Then
        Sheets(i).Delete
    End If
 
Next
 
' ------------------------------------------------------------------------------------------- '
' Recopie de l'onglet du fichier dans ce classeur
' ------------------------------------------------------------------------------------------- '
Workbooks(NomW1).Sheets _
(sHAno).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
 
' Creation de l'onglet Résultat
Add_sheet sHres, True
 
' ------------------------------------------------------------------------------------------- '
' Boucle sur les numéros 1 à MAX
' ------------------------------------------------------------------------------------------- '
Max = 999
For NumErr = 1 To Max
 
    Dim FA As Worksheet, FR As Worksheet, FE As Worksheet
    Dim MaPlage As Range
 
    sHerr = sHerr & NumErr
 
    Set FR = Worksheets(sHres)
    Set FA = Worksheets(sHAno)
 
 
    Set MaPlage = FA.Range("P:P")
    MaPlage.AutoFilter Field:=16, Criteria1:=CStr(NumErr)
 
 
    TotErr = FA.AutoFilter.Range.Columns(16).SpecialCells(xlCellTypeVisible).Cells.Count
 
'On continue seulement si l'erreur n'est pas trouvée
    If TotErr > 1 Then 'La ligne des titres seulement donne 1
 
'Creation de l'onglet erreur des reponses filtrées
        sHerr = LibErr & NumErr
        Add_sheet sHerr, True
        Set FE = Worksheets(sHerr)
 
'Recopie des zones filtrées dans le nouvel onglet
        FA.Cells.SpecialCells(xlCellTypeVisible).Copy
        FE.Paste
 
        FA.Range("A1").EntireRow.Copy
        FE.Rows("1:1").PasteSpecial Paste:=8
        FE.Rows("1:1").AutoFilter
End If
 
'Ne plus filtrer le fichier pour la boucle
MaPlage.AutoFilter Field:=16
Next
 
 
End Sub

Edit : l'utilisation du fichier reçu et de l'onglet resultat ne sont pas présents dans ce code

[aalex_38]

Voila je viens de faire un essai pour placer dans un tableau les différentes valeurs trouvées dans la colonne P.
Mais c'est très long... :

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
Max = 999
Dim MyTab()    As Long
 
Dim FA As Worksheet
 
Set FA = Worksheets(sHAno)
Set MaPlage = FA.Range("P:P")
i = 0
For NumErr = 1 To Max
    MaPlage.AutoFilter Field:=16, Criteria1:=CStr(NumErr)
    TotErr = FA.AutoFilter.Range.Columns(16).SpecialCells(xlCellTypeVisible).Cells.Count
 
    If TotErr > 1 Then 'La ligne des titres seulement donne 1
 
        ReDim Preserve MyTab(i)
        MyTab(i) = NumErr
        i = i + 1
    End If
 
    'Ne plus filtrer le fichier pour la boucle
    MaPlage.AutoFilter Field:=16
Next NumErr
 
For i = LBound(MyTab) To UBound(MyTab)
Debug.Print MyTab(i)
Next i

Edit: Plus d' 1 minute 30 toujours pour le même fichier
==> Aucun gain de temps pour moi de passer comme ça par un tableau, est-ce que quelqu'un aurait un conseil avisé

Sinon je defais et je refais ...

[aalex_38]

Bon comme je dispose d'excel 2007 et que j'ai un fichier avec plus de 100000 lignes je me suis dis que j'allais le traiter avec le format xlsm acceptant un grand nombre de lignes.

Hélas j'ai une erreur de capacité sur la ligne suivante pour lire les quelques 86000 erreurs XXX :

Code :

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

TotErr = FA.AutoFilter.Range.Columns(16).SpecialCells(xlCellTypeVisible).Cells.Count

Je suis en train d'adapter le code car j'ai besoin des résultats assez rapidement.
Si quelqu'un a une idée...


EDIT Au bout d'un moment, j'ai un message "Excel ne peut pas terminer cette tâche avec les ressources disponibles. Sélectionnez moins de données ou fermez des applications. => je fais OK => débogage et là je m'arrête sur le code suivant :

Code :

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

FE.Paste

Ce qui est drole c'est que les données ont bien été copiées, pour contourner le problème je saute donc plusieurs lignes avec le debogguer

Code :

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

1
2
3
4
5
6
7
8
9
'Recopie des zones filtrées dans le nouvel onglet
        FA.Cells.SpecialCells(xlCellTypeVisible).Copy
        FE.Paste '=> Je passe de cette ligne 
        Application.CutCopyMode = False

        FA.Range("A1").EntireRow.Copy
        FE.Rows("1:1").PasteSpecial Paste:=8
        Application.CutCopyMode = False '=> a celle ci 
        FE.Rows("1:1").AutoFilter

La je peux relancer, jusqu'a la boucle suivante
CTRL ALT F8 et c'est reparti

[aalex_38]

Je vous donne la boucle qui me pose problème si quelqu'un pouvait me donner un moyen plus efficace :

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
' ------------------------------------------------------------------------------------------- '
' Boucle sur les numéros 1 à MAX
' ------------------------------------------------------------------------------------------- '
Dim Max As Integer
Max = 999
For NumErr = 1 To Max
 
    Dim FA As Worksheet, FE As Worksheet
    Dim MaPlage As Range
    Dim TotErr As Long, Compteur As Long
 
    ' sHerr = sHerr & NumErr
 
    Set FA = Worksheets(sHAno)
 
 
    Set MaPlage = FA.Range("P:P")
    MaPlage.AutoFilter Field:=16, Criteria1:=CStr(NumErr)
On Error Resume Next
    TotErr = FA.AutoFilter.Range.Columns(16).SpecialCells(xlCellTypeVisible).Cells.Count
On Error GoTo 0
 
If Not TotErr = 1 Then 'La ligne des titres seulement donne 1
 
       TotErr = TotErr - 1
'Creation de l'onglet erreur des reponses filtrées
        sHerr = LibErr & NumErr
        Add_sheet sHerr, False, True
        Set FE = Worksheets(sHerr)
 
'Recopie des zones filtrées dans le nouvel onglet
        FA.Cells.SpecialCells(xlCellTypeVisible).Copy
        FE.Paste
        Application.CutCopyMode = False
 
        FA.Range("A1").EntireRow.Copy
        FE.Rows("1:1").PasteSpecial Paste:=8
        Application.CutCopyMode = False
        FE.Rows("1:1").AutoFilter
 
' Ecrire le numéro d'erreur dans l'onglet resultat
        MaCellule.Offset(Compteur, 0) = NumErr
        MaCellule.Offset(Compteur, 1) = TotErr
        Compteur = Compteur + 1
 
End If
 
'Ne plus filtrer le fichier pour la boucle
MaPlage.AutoFilter Field:=16
 
Next

Merci d'avance.

Ce n'est plus aussi urgent le code vient de se terminer, laborieux mais bon le résultat est là.
Comme j'aurai de nouveau besoin de ce code sur des gros fichiers please help

[aalex_38]

Finalement je suis parti sur une autre idée et ça fonctionne :

Tri de l'onglet sur le numéro d'erreur pour commencer et ensuite écriture à chaque rupture sur le numéro dans un nouvel onglet.

Je n'ai pas tout a fait terminé, je mets sur résolu dès que c'est fait.

Le nouveau 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
Private Sub Boucle_reponseIII()
Dim NumErr As Integer, NumErr_Res As Integer
Dim CellErr As Range
Dim TotErr As Long
Dim FA As Worksheet, sHAno As String
 
Dim sHres As String, sHerr As String
Const LibErr As String = "Err"
 
sHerr = LibErr
sHres = "Résultats "
sHAno = "xxx"
 
Set FA = Worksheets(sHAno)
 
Dim MaPlage As Range
Set MaPlage = FA.Range("P2:P" & Range("P1048576").End(xlUp).Row)
 
' ------------------------------------------------------------------------------------------- '
' Tri du Fichier sur la colonne P contenant les numéros
' ------------------------------------------------------------------------------------------- '
 
With ThisWorkbook.Worksheets(sHAno).Sort
    .SortFields.Add Key:=MaPlage, SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortTextAsNumbers
    .SetRange Range("A1:R105228")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
 
 
For Each CellErr In MaPlage
    TotErr = TotErr + 1
    NumErr = CellErr
    If NumErr = NumErr_Res Then
    Else
        ' creation de l'onglet pour le numero d'erreur
        sHerr = LibErr & NumErr
        Add_sheet sHerr, False, True
        Set FE = Worksheets(sHerr)
        LigErr = 0
    End If
 
    LigErr = LigErr + 1
 
    CellErr.EntireRow.Copy Destination:=FE.Cells(LigErr, 1)
    Application.CutCopyMode = False
 
 
NumErr_Res = NumErr
Next CellErr
 
MsgBox TotErr
 
 
Exit Sub

[aalex_38]

Finalement ce code m'a bien servi dans ma mission précédente