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

Bonjour,

Je n'arrive toujours pas à trouver de solution..

Les deux macros que j'utilise fonctionnent bien, mais, selon la taille du tableau, alors ça ne fonctionne plus correctement.

Si ma plage de données ne contient que quelques milliers de lignes j'ai le résultat que je veux, si elle en contient 28 000, alors la macro ne parvient plus à lister les infos demandées...

Je joins à nouveau via cjoin, un document avec la base de données complètes si vous souhaitez y jeter un œil..

Je ne sais vraiment pas quoi faire pour résoudre ça, le tableau est correctement délimité, la copie des données se fait bien pour les premières lignes traitées et puis ça ne fonctionne plus correctement.

Lien vers le document :

Je vous remercie de votre attention

En espérant que vous sachiez ce qui cloche ici !

Bonne journée !

Bonjour,

J'en déduis que le filtre avancé ne t'intéresse pas.

eric

La macro actuellement utilisée fonctionne très bien dans certaines circonstances mais pas lorsque la "base de données" est complète. Le souci n'a pas l'air de provenir de la macro qui sert à filtrer et copier les données, mais de la macro qui sert à délimiter le tableau.

J'ai fais quelques essais avec les codes proposés pour les filtres avancés, mais sans grand succès. J'avais l'impression de travailler sur une macro qui fonctionnait déjà telle qu'elle.

Bonjour,

J'ai découpé le code en plusieurs parties pour essayer de trouver une solution en cherchant différemment.

Macro pour insérer le bon nombre de lignes (OK)

Sub insertrow()
Dim code As String, i%
Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
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
        lrbdd = Application.Subtotal(3, Range("S:S")) - 1

        If lrbdd > 0 Then
            pn.Cells(i + 1, 1).Resize(lrbdd - 1, 1).EntireRow.Insert
        End If
    Next i
End With
End Sub

Macro pour compléter les lignes vides (OK) ; il sert pour le code suivant :

Sub compl()

Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")
lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row

With pn
    For i = 2 To lrpn
        If .Cells(i + 1, 2) = "" Then: .Cells(i + 1, 2) = .Cells(i, 2)
    Next i
End With
End Sub

Macro pour rechercher les données une à une :

Sub rech()
Dim code As String, i%, plg As Range, re As Range, e As Variant

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

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
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)
            Set re = plg.Find(code, Lookat:=xlWhole)
            If Not re Is Nothing Then
                'For Each e In plg(19)
                    pn.Cells(i, 3).Value = re.Offset(, 16) 'e.Value
                'Next e
            Else
                pn.Cells(i, 3) = "Non concerné"
            End If
    Next i
End With
End Sub

Mais je bloque à nouveau sur la recherche des données. En l'état, la macro recherche toujours la première ligne, ce qui fait que le résultat est répété autant de fois qu'il y a de recherche.

Pour le moment je n'ai pas trop compris le fonctionnement des filtres avancés et ça n'a pas donné de résultat. Il utilise des range bien définis, mais en l'occurrence mes données ne sont pas toujours au même nombre. Et délimiter le range c'est un des problèmes que j'ai avec les macros que j'utilise déjà ; Excel ne repère pas (toujours) les données, donc il ne peut pas délimiter de range.

A plus tard

Le Drosophile a écrit :

La macro actuellement utilisée fonctionne très bien dans certaines circonstances mais pas lorsque la "base de données" est complète. Le souci n'a pas l'air de provenir de la macro qui sert à filtrer et copier les données, mais de la macro qui sert à délimiter le tableau.

J'ai fais quelques essais avec les codes proposés pour les filtres avancés, mais sans grand succès. J'avais l'impression de travailler sur une macro qui fonctionnait déjà telle qu'elle.

re,

il y a des doublons dans la base de données,

est ce que le problème vient de là ?

Bonjour,

Ils ne posent pas de problème dans mes tests.

Bonsoir,

Au vu du titre 'recherches dans filtres données visibles' , j'ai pensé que ceci pouvait peut-être te concerner.

Ce pgm recherche dans toutes les colonnes d'une zone filtrée un mot (ou plusieurs mots)

Boisgontier

Bonsoir,

Je n'avais plus de connexion internet et n'ai donc pas vu votre message ce soir...

Pendant ce temps, j'ai testé une autre solution qui s'est avérée fonctionnelle !

Le code s'exécute en une quinzaine de secondes (je suis certain qu'en utilisant d'autres macros ça pourrait être plus rapide) et réalise exactement ce que je voulais faire.

Le même résultat qu'avec la macro de i20100 ; mais qui fonctionne à chaque fois, même lorsque le tableau est délimité par une macro (le code proposé par i20100 était bien plus efficace, mais, par je ne sais quel mystère, il ne fonctionnait plus dès que le tableau était à nouveau délimité...).

Pour résoudre mon souci j'ai procédé comme suit :

A l'import de la base de données, une nouvelle colonne est créée, avec un identifiant unique généré à partir des codes présents en colonne 3 ("SITECODE") et une numérotation partant de 1 à chaque fois.

Par la suite, les données sont filtrées pour que la recherche se fasse uniquement sur elles (j'ai comme un doute là dessus.., je ne serais pas étonné que la recherche se fasse dans tout le document).

Dans mon tableau qui sert pour la recherche, je génère des identifiants similaires en utilisant le code "SITECODE" (LEFT ; 9 premiers caractères) et une numérotation partant de 1.

Je n'ai plus qu'à lancer une recherche, Excel ne peut plus faire autrement que trouver le résultat !

Je joins le document fonctionnel.

Voici les codes utilisés :

Lors de l'import de la base de données, pour générer les identifiants et délimiter le tableau :

'Lors de l'import de la base de données (code 1)
Sub majbdd()
Dim c&, plg As Range, nb%, x%, lcbdd&
Set bdd = Worksheets("BDD ""SPECIES""")

With bdd
    cib = .Rows("1:1").Find("NOM", LookIn:=xlValues, Lookat:=xlWhole).Column
    cib1 = .Rows("1:1").Find("SITECODE", LookIn:=xlValues, Lookat:=xlWhole).Column
    lrbdd = .Cells(.Rows.Count, 3).End(xlUp).Row
    lcbdd = .Cells(1, .Columns.Count).End(xlToLeft).Column

'Classement des données
    .Range(.Cells(2, 1), .Cells(lrbdd, lcbdd)).Sort _
    Key1:=.Range(.Cells(2, cib1), .Cells(lrbdd, cib1)), Order1:=xlAscending

'maj colonne
x = 1
    .Columns(cib + 1).ClearContents
        .Cells(2, cib + 1) = .Cells(2, cib1) & x
        For c = 3 To lrbdd
            If .Cells(c - 1, cib1) = .Cells(c, cib1) Then
                x = x + 1
                .Cells(c, cib + 1) = .Cells(c, cib1) & x
            Else
                x = 1
                    .Cells(c, cib + 1) = .Cells(c, cib1) & x
            End If
        Next c
End With
End Sub

'Lors de l'import de la base de données (code 2)
Sub structabBDD()
Dim ts As ListObject
Set bdd = Worksheets("BDD ""SPECIES""")

    With bdd
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Tab_spec"
        Else
        Set ts = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes)
        ts.Name = "Tab_spec"
        End If
    End With

Set ts = Nothing
End Sub

Pour insérer le bon nombre de lignes.

Sub insertrow()
Dim code As String, i%
Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
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
        lrbdd = Application.Subtotal(3, Range("S:S")) - 1

        If lrbdd > 0 Then
            pn.Cells(i + 1, 1).Resize(lrbdd - 1, 1).EntireRow.Insert
        End If
    Next i
End With
End Sub

Pour remplir toute les lignes (et avoir le code site à chaque fois)

Sub compl()
Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")
lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row

With pn
    For i = 2 To lrpn - 1
        If .Cells(i + 1, 2) = "" Then: .Cells(i + 1, 2) = .Cells(i, 2)
    Next i
End With
End Sub

Générer les mêmes identifiants à partir des infos du tableau

Sub majpn()
Dim c&, plg As Range, nb%, x%, lcbdd&
Set pn = Worksheets("Périmètres N2000")

With pn
    cib = .Rows("1:1").Find("Lien écologique", LookIn:=xlValues, Lookat:=xlWhole).Column
    cib1 = .Rows("1:1").Find("Nom du site", LookIn:=xlValues, Lookat:=xlWhole).Column
    lrpn = .Cells(.Rows.Count, 2).End(xlUp).Row

'compléter colonne
x = 1
    .Columns(cib + 1).ClearContents
        .Cells(2, cib + 1) = Left(.Cells(2, cib1), 9) & x
        For c = 3 To lrpn
            If Left(.Cells(c - 1, cib1), 9) = Left(.Cells(c, cib1), 9) Then
                x = x + 1
                .Cells(c, cib + 1) = Left(.Cells(c, cib1), 9) & x
            Else
                x = 1
                .Cells(c, cib + 1) = Left(.Cells(c, cib1), 9) & x
            End If
        Next c
End With
End Sub

Réaliser la recherche

Sub rech()
Dim code As String, code1 As String, i%, plg As Range, re As Range, e As Variant

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

lrpn = pn.Cells(pn.Rows.Count, 2).End(xlUp).Row
With bdd
cib = pn.Rows("1:1").Find("Lien écologique", LookIn:=xlValues, Lookat:=xlWhole).Column
    For i = lrpn To 2 Step -1
        code = Left(pn.Cells(i, 2), 9)
        code1 = pn.Cells(i, 6)
        .ListObjects("Tab_spec").Range.AutoFilter Field:=3, Criteria1:="=" & code, Operator:=xlAnd
        .Activate
        On Error Resume Next
        Set plg = .ListObjects("Tab_spec").DataBodyRange.SpecialCells(xlCellTypeVisible)
            Set re = plg.Find(code1, Lookat:=xlWhole)
            If Not re Is Nothing Then
                'For Each e In plg(19)
                    pn.Cells(i, 3).Value = re.Offset(, -1) 'e.Value
                'Next e
            Else
                pn.Cells(i, 3) = "Non concerné"
            End If
    Next i
pn.Columns(cib + 1).ClearContents

'Remettre la base de données en état
.Cells(1, 3).AutoFilter
End With
End Sub

Mettre en forme le tableau

Sub majtab()
Dim lcpn&
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set pn = Worksheets("Périmètres N2000")
With pn
    cib = .Rows("1:1").Find("Distance avec le projet", LookIn:=xlValues, Lookat:=xlWhole).Column
    cib1 = .Rows("1:1").Find("Nom du site", LookIn:=xlValues, Lookat:=xlWhole).Column
    lrpn = .Cells(.Rows.Count, cib1).End(xlUp).Row
    lcpn = .Cells(1, .Columns.Count).End(xlToLeft).Column

'Supprimer les doublons
.Range(.Cells(2, 1), .Cells(lrpn, lcpn)).RemoveDuplicates Columns:=Array(3)

'Mettre en forme le tableau
    For i = lrpn To 2 Step -1
        If .Cells(i, cib1) = .Cells(i - 1, cib1) Then
            .Range(.Cells(i, cib1), .Cells(i - 1, cib1)).Merge
            .Range(.Cells(i, cib), .Cells(i - 1, cib)).Merge
        End If
    Next i
End With

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Lien cjoint :

Je vous remercie pour votre aide !

Je vais regarder le docupent que vous proposez, peut-être cela me permettra de trouver une solution plus rapide !

Bonne fin de soirée