[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.
La feuille de travail s'appelle : "Périmètres N2000"
La Base de données complète sur la feuille : "BDD "SPECIES""
Copie de la base de données complète : "allbdd - fonctionne pas"
Copie d'une partie de la bdd, (le code fonctionne avec, pour la ligne traitée) : bdd incomplete (fonctionne)
Copie de ce qui doit se trouver dans la feuille "Périmètres N2000" avant le lancement du code se trouve sur feuille "save".
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
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