[VBA] - Recherche dans filtres - données visibles

Bonsoir,

Dans mon document Excel, j'essaie de lancer une recherche d'un code, dans une base de données, en passant par des filtres pour accélérer la procédure.

Le problème, c'est que dans certains cas, j'ai des erreurs et je n'arrive pas bien à comprendre d'où cela provient.

Spoiler

J'ai une erreur "Dépassement de capacité" qui apparaît si j'utilise :

q = plage.SpecialCells(xlCellTypeVisible).Count

Et l'erreur "Pas de cellule correspondante " si j'utilise

Set plage = bdd.Range(.Cells(2, cib), .Cells(lrbdd, cib)).SpecialCells(xlCellTypeVisible)
q = plage.Count

Le mieux étant d'expliquer ce que je cherche à faire :

  • Dans la feuille "Périmètres N2000"
  • Enregistrer le numéro inscrit en [colonne B] (Exemple : FR9110108) [J'utilise ce code : Left(.Cells(i, 2), 9)]
  • > L'utiliser pour filtrer la [colonne C] de la feuille "BDD "SPECIES"".
  • En [colonne S] de la feuille "BDD "SPECIES"" ne s'afficheront que les "NOM" qu'il faut copier.
  • Insérer le nombre de ligne correspondant au nombre de données copiées en [colonne C] de la feuille "Périmètres N2000"
  • Coller ces "NOM" en [colonne C] de la feuille "Périmètres N2000"

- Recommencer pour le numéro suivant dans la feuille "Périmètres N2000".

Je joins un document via cjoin car il pèse 2Mo.

Je vous remercie de votre attention.

Bonne soirée ! A plus tard

Bonjour,

j'ai transformé les données de la base en tableau,

par expérience je trouve que c'est la solution la plus fiable pour récolter les données filtrées

j'ai ajouté un onglet "tempo" pour récolter les données filtrées

et transférer le résultat final sur l'onglet "résultat"

j'ai aussi réduit le nombre de ligne de la base pour pour réduire le fichier à moins de 1000 ko

à tester,

Bonjour,

Je vous remercie pour votre réponse.

Votre code fonctionne, mais j'aimerais faire en sorte qu'il ne travaille que sur une feuille si possible.

Mon unique problème (pour le moment, a priori) c'est que je ne parviens pas à lui faire compter le nombre de lignes filtrées visibles. Soit il m'indique 0, soit un chiffre qui n'est pas le bon (19 en l'occurrence... ; alors qu'1 seule ligne est visible, hors en-tête).

J'ai utilisé ces codes ci :

           lrbdd = bdd.Cells(bdd.Rows.Count, 1).End(xlCellTypeVisible).Row '=> 0
           lrbdd = bdd.SpecialCells(xlCellTypeVisible).Count / 19 ' => Erreur
           lrbdd = bdd.ListObjects("Tab_spec").SpecialCells(xlCellTypeVisible).Count '=> 0
           lrbdd = bdd.ListObjects("Tab_spec").Count '=> 0

    Dim NoLigne(), t, j, a
    Dim ligne As Variant
        For Each ligne In bdd.ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible) 'bdd.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows
            t = t + 1
            ReDim Preserve NoLigne(t)
            NoLigne(t) = ligne.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        Next 
'=> 19

Comment puis-je faire pour qu'Excel compte le nombre de cellules visibles ?

Exactement comme il le fait lorsque je sélectionne une colonne et qu'il affiche dans le bandeau du bas : Nb (non vides) : x)

Bonne journée !

Comment puis-je faire pour qu'Excel compte le nombre de cellules visibles ?

Exactement comme il le fait lorsque je sélectionne une colonne et qu'il affiche dans le bandeau du bas : Nb (non vides) : x)

re,

tu pourrais utiliser la fonction Sous.Total

n = Application.Subtotal(2, Range("A:A"))

Bonsoir,

Merci pour votre réponse, cela m'a débloqué dans mon problème, mais hélas je n'ai pas réussi à faire ce que j'espérais.

Le code dont il est question est le suivant :

Sub Compdatapnsps()
Dim temp As Worksheet, rs As Worksheet
Dim code As String, rw1&, rw2&, lrbdd&
Dim plg As Range

Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
cib = bdd.Rows("1:1").Find("NOM", LookIn:=xlValues, Lookat:=xlWhole).Column

With bdd
    For i = lrpn To 2 Step -1
        code = Left(pn.Cells(i, 2), 9)
        .ListObjects("Tab_spec").Range.AutoFilter Field:=3, Criteria1:="=" & code, Operator:=xlAnd
        'On Error Resume Next
                .Activate
                lrbdd = Application.Subtotal(3, Range("S:S"))

                'Insérer le nombre de lignes adéquat
                pn.Activate
                    If lrbdd > 1 Then
                        pn.Cells(i, 1).Resize(lrbdd - 2, 1).EntireRow.Insert
                        'Set rng = .Range(.Cells(2, cib), .Cells(lrbdd, cib))
                        'Set rng = .Cells(2, cib).SpecialCells(xlCellTypeVisible)
                        Set rng = bdd.ListObjects("Tab_spec").Application.Subtotal(3, Range("S:S")) '.SpecialCells(xlCellTypeVisible)
                        rng.Copy Destination:=pn.Cells(i, 3)
                    Else
                        pn.Cells(i, 3) = "Non concerné"
                    End If
    Next i
End With
End Sub

Et mon erreur se situe là :

                        'Set rng = .Range(.Cells(2, cib), .Cells(lrbdd, cib))
                        'Set rng = .Cells(2, cib).SpecialCells(xlCellTypeVisible)
                        Set rng = bdd.ListObjects("Tab_spec").Application.Subtotal(3, Range("S:S")) 

A nouveau, je n'arrive pas à faire comprendre à Excel que je veux copier les données visibles présentes en colonne S.

Il me copie un peu n'importe quoi, même des données issues d'une autre page que "bdd"

Je vais essayer s'adapter votre méthode à ce code ci, ces prochains jours, et reviendrai poster le resultat s'il fonctionne..

Bonne soirée !

Bonjour à tous,

.SubTotal retourne un nombre, pas un range. Tu ne peux pas l'affecter avec Set (reservé aux objets, comme un Range)

C'est une bonne solution pour ton pb.

Cependant je vais t'expliquer tes erreurs avec SpecialCells, pour une prochaine fois...

  • SpecialCells génère une erreur si rien n'est trouvé, il faut la gérer
  • la plage résultante peut être fragmentée. Tu ne peux donc pas avoir directement le nombre de lignes, il faut compter celles de chaque area.
Ce qui donne :
Dim pl As Range, ar As Range, nblig As Long

            ' tes filtres...
            '
            Set pl = Nothing: nblig = 0
            On Error Resume Next
            Set pl = bdd.Cells.Resize(bdd.Cells(bdd.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not pl Is Nothing Then
                For Each ar In pl.Areas
                    nblig = nblig + ar.Rows.Count
                Next ar
            End If
            MsgBox nblig ' & " lignes : " & pl.address

eric

Bonjour,

Bonjour Eriiic,

Pour commencer mes meilleurs vœux pour cette nouvelle année.

Je pense que ceci est fonctionnel ?

On Error Resume Next
Set pl = bdd.Cells.Resize(bdd.Cells(bdd.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
n = pl.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
On Error GoTo 0

Cdlt.

Bonjour,

Concernant le code :

            Set pl = Nothing: nblig = 0
            On Error Resume Next
            Set pl = bdd.Cells.Resize(bdd.Cells(bdd.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not pl Is Nothing Then
                For Each ar In pl.Areas
                    nblig = nblig + ar.Rows.Count
                Next ar
            End If

nblig = le bon nombre de lignes (il prend en compte la première ligne, à retirer ensuite)

En revanche,

n = pl.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

n = 0 ; il ne semble pas compter le nombre de ligne (= 0 avec ou sans -1).

Mais finalement,

lrbdd = Application.Subtotal(3, Range("S:S"))

fait très bien le travail, puisqu'il semble également compter le bon nombre de lignes.

C'est ensuite, lorsque je cherche à copier la plage visible (de 2 à "dernière ligne visible") que ça ne marche pas.

Je n'ai pas encore fait les tests en remixant avec le précédent code de i20100.

A plus tard !

Bonjour,

Un exemple fonctionnel pour compter le nombre de cellules filtrées.

Cdlt.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lo As ListObject, Rng As Range, n As Long
    If Target.Address = "$D$3" Then
        Set lo = Range("Data").ListObject
        lo.Range.AutoFilter field:=1, Criteria1:=Target.Value
        Set Rng = lo.AutoFilter.Range
        'On Error Resume Next
        MsgBox Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 _
               & " of " & Rng.Rows.Count - 1 & " Enregistrements"
        'On Error GoTo 0
        lo.Range.AutoFilter field:=1
    End If
End Sub

Re,

Un code qui fonctionne quasiment :

Dim temp As Worksheet, rs As Worksheet
Dim code As String, rw1&, rw2&, lrbdd&
Dim plg As Range, plg1 As Range

Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
cib = bdd.Rows("1:1").Find("NOM", LookIn:=xlValues, Lookat:=xlWhole).Column

With bdd
    For i = lrpn To 2 Step -1
        code = Left(pn.Cells(i, 2), 9)
        .ListObjects("Tab_spec").Range.AutoFilter Field:=3, Criteria1:="=" & code, Operator:=xlAnd
        .Activate
        On Error Resume Next
        Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible)
        'If Err.Number <> 0 Then GoTo 0
        On Error Resume Next
        lrbdd = Application.Subtotal(3, Range("S:S")) - 1

                'Insérer le nombre de lignes adéquat
                pn.Activate
                    If lrbdd > 0 Then
                        pn.Cells(i, 1).Resize(lrbdd - 1, 1).EntireRow.Insert
                        plg.Columns(19).Copy pn.Cells(i, 3)
                    Else
                        pn.Cells(i, 3) = "Non concerné"
                    End If

    Next i

'suivant:

End With
End Sub

Il reste un problème avec Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible)

La plage fait parfois le bon nombre de lignes et parfois pas... donc si je copie la plage, je ne copie que "x" lignes du tableaux, pas toutes celles affichées. Comme si Excel ne "voyait" pas certaines lignes, qui sont bel et bien visibles.

Je regarde votre document de suite.

Quelques essais sans succès, en m'inspirant de votre code.

       'Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible)
'        Set plg = .ListObjects("Tab_spec").AutoFilter.Columns(19)
        Set plg = .Columns(19).SpecialCells(xlCellTypeVisible)

Bonjour,

Mon code est pratiquement fonctionnel, mais il ne copie pas toutes les cellules visibles. Si vous voulez y jeter un œil, je joins un document où vous pourrez voir que le nombre de lignes ajoutées est le bon, mais leur remplissage est manquant.

Je n'ai pas encore essayé avec un dictionnaire, cela permettrait, par ailleurs, de supprimer les doublons tout de suite.

Je vais faire quelques recherches sur la création d'un dictionnaire à partir de cellules visibles. Il y a peut-être une solution.

Bonne journée !

A plus tard.

J'ai testé comme ceci :

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
lr = bdd.Cells(bdd.Rows.Count, 1).End(xlUp).Row
cib = bdd.Rows("1:1").Find("NOM", LookIn:=xlValues, Lookat:=xlWhole).Column

With bdd
    For i = lrpn To 2 Step -1
        code = Left(pn.Cells(i, 2), 9)
        .ListObjects("Tab_spec").Range.AutoFilter Field:=3, Criteria1:="=" & code, Operator:=xlAnd
        .Activate
        'On Error Resume Next
'        Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible) 'Presque OK
        On Error Resume Next
        lrbdd = Application.Subtotal(3, Range("S2:S" & lr))
        If lrbdd = 1 Then lrbdd = 2
        Set plg = .ListObjects("Tab_spec").Range(.Cells(2, cib), .Cells(lrbdd, cib)).SpecialCells(xlCellTypeVisible)
'        Set plg = .ListObjects("Tab_spec").AutoFilter.Columns(19)
'        Set plg = .Columns(19).SpecialCells(xlCellTypeVisible)
'        If Err.Number <> 0 Then GoTo 0

        Set D = CreateObject("Scripting.Dictionary")      'définit le dictionnaire D
                For Each c In plg '.Range(.Cells(2, cib), .Cells(lrbdd, cib))
                    If Not D.Exists(c) Then D(c.Value) = c.Value
                Next c

'Suite...

Sans succès...

plg = nothing

Bonsoir,

J'ai continuer à chercher un peu, en vain.

Pour le moment j'ai mis au propre les codes pour que le mien, mis à jour avec des éléments de i20100 ainsi que la macro de i20100 fonctionnent sur le même document.

On peut constater la même erreur qui se produit :

Le bon nombre de ligne est généré, en revanche, les cellules de la colonne C ["Habitat(s) et espèce(s) Natura 2000"] ne sont pas renseignées correctement, il reste beaucoup de vides.

Dans certains cas, Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible) délimite la plage de données correctement, mais dans d'autre cas non. Seules les premières cellules sont bonnes.

Si vous avez une idée de la provenance de cette erreur

A plus tard !

Bonne soirée

J'ai oublié de joindre le document..

Je fais un lien cjoin pour qu'il soit bien complet.

A plus tard !

re,

à tester,

Private Sub CommandButton1_Click()
Dim temp As Worksheet, rs As Worksheet
Dim code As String, rw1&, rw2&, lrbdd&
Dim plg As Range, plg1 As Range

Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
cib = bdd.Rows("1:1").Find("NOM", LookIn:=xlValues, Lookat:=xlWhole).Column
bdd.ListObjects("Tab_spec").Range.AutoFilter Field:=3

With bdd
    For i = lrpn To 2 Step -1
        code = Left(pn.Cells(i, 2), 9)
        .ListObjects("Tab_spec").Range.AutoFilter Field:=3, Criteria1:="=" & code, Operator:=xlAnd
        .Activate
        On Error Resume Next
        Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible)

        On Error Resume Next
        lrbdd = Application.Subtotal(3, Range("S:S")) - 1

                'Insérer le nombre de lignes adéquat
                pn.Activate
                    If lrbdd > 0 Then
                        pn.Cells(i + 1, 1).Resize(lrbdd - 1, 1).EntireRow.Insert
                        plg.Columns(19).Copy pn.Cells(i, 3)
                    Else
                        pn.Cells(i, 3) = "Non concerné"
                    End If
    Next i
End With
End Sub

Bonsoir,

Le résultat est le même, seules la première ou les 2 premières données sont récupérées puis collées dans la colonne.

Cette partie de la macro : plg.Columns(19).Copy pn.Cells(i, 3)

Ne semble pas copier l'ensemble des données en colonnes 19, mais seulement quelques unes

Je vous remercie pour votre proposition, cela a t-il fonctionné sur votre document ???

Bonne soirée,

A plus tard !

re,

voici le résultat obtenu,

Bonjour,

Je comprends enfin d'où vient le problème.

Il vient de la macro servant à délimiter le tableau qui ne fonctionne pas... Je dois trouver pourquoi..

Merci beaucoup pour votre aide !!

Bonne journée !

Bonjour,

tu peux utiliser un filtre avancé qui peut extraire sur une autre feuille

eric

Rechercher des sujets similaires à "vba recherche filtres donnees visibles"