autofilter and usedrange

Version imprimable

Bonsoir à tous

je ne saisis pas encore toutes les subtilités de l'autofilter.
j'arrive à filtrer et obtenir les lignes affichées avec le visiblerow
mais quand je tente d'identifier toutes les lignes dans un range cela ne fonctionne pas

En effet TotalRange selectionne bien les lignes hormis le header mais semble t'il plus car quand je te tente d'afficher en listbox totalrange cela affiche tous les résultats entre

dans mon cas je voudrais pouvoir avoir seulement les lignes de l'autofilter..

quelqu'un pourrait il m'éclairer merci
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 Private Sub List_Projects() Dim Rng As Range Dim derlign As Integer Dim PJ_page As Worksheet Set PJ_page = Sheets("Projects") derlign = PJ_page.cells(Rows.Count, "A").End(xlUp).row PJ_page.Range("A1").AutoFilter _ field:=13, _ Criteria1:="Active", _ VisibleDropDown:=True cnt = 1 For Each cnt In Intersect(PJ_page.UsedRange, PJ_page.Range("A2:A" & derlign).SpecialCells(xlCellTypeVisible)) visiblerow = cnt.row MsgBox (visiblerow) Next Set TotalRange = PJ_page.UsedRange Set TotalRange = TotalRange.Offset(1, 0).Resize(TotalRange.Rows.Count - 1, _ TotalRange.Columns.Count) Set Rng = TotalRange End Sub

Bonsoir,

Ces quelques éléments devraient vous aider

Code:

1
2
3
4
    PJ_page.Range("A1").AutoFilter field:=13, Criteria1:="Active", VisibleDropDown:=True
    NbCol = [ZZ1].End(xlToLeft).Column 'nombre de colonnes
    NbLig = Range("_FilterDataBase").Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1 'Nombre de lignes après filtrage
    Range("_FilterDataBase").Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy 'vers la destination de votre choix

Cdlt

14/05/2020, 10h36
Darkangel2014

merci à vous
cela fonctionne bien pour colonne mais pour les lignes non

La méthode Range de l'objet _Global à échoué!
14/05/2020, 10h46
ARTURO83

Bonjour,

Afin que je puisse voir où ça coince, pourriez-vous déposer ici un extrait de votre fichier? (remplacez les données confidentielles par des valeurs bidons)
14/05/2020, 11h07
Darkangel2014

je vais tenter de préparer cela même si cela risque de prendre du temps

toutefois et après examen c'est

_FilterDatabase qui ne semble même pas reconnu...

Code:

PJ_page.Range("_FilterDataBase").Select

c'est encore la méthode range de worksheet cette fois qui ne fonctionne pas
14/05/2020, 11h34
Darkangel2014

1 pièce(s) jointe(s)

Voici un fichier retraçant mon soucis

Pièce jointe 565468

merci par avance pour votre aide

Bonjour,

Evidemment, dans un tableau structuré, les commandes ne sont plus tout à fait les mêmes, voici la modif pour les2 lignes de sélection et recopie de la zone filtrée. Pour la compréhension, j'applique la recopie sur la feuille 1, à vous de modifier et d'appliquer sur la destination de votre choix.
Code:

1 2 3 NbLig = PJ_page.ListObjects("Projects").DataBodyRange.Resize(, 1).SpecialCells(xlCellTypeVisible).Count 'Nombre de lignes après filtrage PJ_page.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy Sheets("Feuil1").Range("A1")
Le fichier
Pièce jointe 565526

Cdlt

14/05/2020, 17h41
Darkangel2014

je vous remercie pour votre retour.
cela fonctionne en effet mais je ne souhaite pas copier mais juste selectionner la plage pour en afficher le contenu dans un listbox
mais je vais tenter de me dépatouiller

merci à vous et bonne soirée
14/05/2020, 17h51
Darkangel2014

je tente néanmoins un

Code:

Set Rng = PJ_page.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible)

mais j'ai le droit à une erreur 1004.
pourtant si on peut copier la sélection on doit pouvoir l'avoir en tant que plage non?
14/05/2020, 18h03
ARTURO83
Citation:

je tente néanmoins un Set Rng = PJ_page.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible)
mais j'ai le droit à une erreur 1004.
pourtant si on peut copier la selection on doit pouvoir l'avoir en tant que plage non?

Bizarre, je n'ai pas ce problème, voici ce que j'ai essayé et la plage "Rng" est bien sélectionnée, avez-vous fait la même chose?
Code:

1 2 Set Rng = PJ_page.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible) Rng.Select

effectivement vous avez raison
entre temps j'ai reussi mais toujours est il que la plage n'est pas correctement affichée dans la listbox
ca ne prend que la première ligne..et encore pas correctement affichée

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
PJ_page.Range("A1").AutoFilter _
 field:=13, _
 Criteria1:="Active", _
 VisibleDropDown:=True
 
NbCol = [ZZ1].End(xlToLeft).Column 'nombre de colonnes
Set Rng = PJ_page.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible)
Rng.Select
 
ColVisu = Array(3, 5, 6)
LargeurCol = Array(80, 80, 80)
  Me.List_Active_Projects.ColumnCount = UBound(ColVisu) + 1
  Me.List_Active_Projects.ColumnWidths = Join(LargeurCol, ";")
  Me.List_Active_Projects.List = Application.index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), ColVisu)

une idée svp?

14/05/2020, 18h25
ARTURO83

Citation:

entre temps j'ai reussi mais toujours est il que la plage n'est pas correctement affichée dans la listbox
ca ne prend que la première ligne..et encore pas correctement affichée

Quelle Listbox? Ou est-elle? Que voulez-vous y mettre dedans? Vous ne présentez que des bribes de codes, comment voulez-vous que je me fasse une idée de ce que vous attendez, si je n'ai pas tous les éléments?
14/05/2020, 18h45
Darkangel2014

1 pièce(s) jointe(s)

oups milles excuses j'ai oublié de joindre le document au code
Pièce jointe 565564

Bonjour,

Conservation de la feuille de récupération de la zone filtrée, puis après suppression des colonnes inutiles, copie vers la listbox.
le fichier
Pièce jointe 565616

Le code utilisé

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub List_Projects()
    Dim Liste
    Dim f1 As Worksheet, f2 As Worksheet
    Dim NbCol As Long
 
    Set f1 = Sheets("Projects")
    Set f2 = Sheets("Feuil1")
    f2.Cells.ClearContents
    f1.Range("A1").AutoFilter field:=13, Criteria1:="Active", VisibleDropDown:=True
 
    NbCol = [ZZ1].End(xlToLeft).Column
    f1.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy f2.Range("A1")
    f2.Columns("B:L").Delete
    Liste = f2.Range("A1:B" & Range("A1").End(xlDown).Row)
    List_Active_Projects.ColumnCount = UBound(Liste)
    List_Active_Projects.List() = Liste
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

15/05/2020, 09h17
Darkangel2014

Bonjour et merci pour votre retour et le fichier.
En effet cela fonctionne parfaitement mais je trouve le process un peu lourd et lent?
est on obligé de passer par une feuille intermédiaire pour information et compréhension?

merci à vous en tout cas

Bonjour,

Citation:

mais je trouve le process un peu lourd et lent?

Etonnant,pour améliorer la vitesse d'éxécution, j'ai ajouté la ligne

Code:

Application.ScreenUpdating = False

De plus j'ai mis un timer pour mesurer le temps d'exécution, sur mon PC avec le tableau fourni, il met 0,015 secondes, temps que j'estime très correct, combien met-il chez-vous?

Citation:

est on obligé de passer par une feuille intermédiaire pour information et compréhension?

Peut-être pas, mais travailler directement à partir d'une zone filtrée, je ne connais pas, mais si d'aventure quelqu'un qui sait et passe par là...
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Private Sub List_Projects() Dim Liste Dim f1 As Worksheet, f2 As Worksheet Dim NbCol As Long Deb = Timer Application.ScreenUpdating = False Set f1 = Sheets("Projects") Set f2 = Sheets("Feuil1") f2.Cells.ClearContents f1.Range("A1").AutoFilter field:=13, Criteria1:="Active", VisibleDropDown:=True NbCol = [ZZ1].End(xlToLeft).Column f1.ListObjects("Projects").DataBodyRange.Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy f2.Range("A1") f2.Columns("B:L").Delete Liste = f2.Range("A1:B" & Range("A1").End(xlDown).Row) List_Active_Projects.ColumnCount = UBound(Liste) List_Active_Projects.List() = Liste Set f1 = Nothing Set f2 = Nothing MsgBox "Temps déxécution: " & Timer - Deb & " Sec" End Sub
Cdlt

15/05/2020, 09h56
Darkangel2014

Merci pour votre retour rapide.

En terme de temps je suis à 0.03 donc cela convient je parlais plus de passer par une feuille intermédiaire