[VBA] - Rechercher dans toute la plage et pas uniquement le 1er résultat
Bonjour,
J'utilise ce code (spoiler ci-après), pour rechercher une des informations d'une feuille à l'autre.
Le problème, c'est que pour le moment, la recherche ne se fait que sur la première ligne trouvée et si les informations ne concordent pas aux arguments de ma recherche, alors le code se termine sans que les informations demandées (et qui existent) ne soient récupérées.
Option Explicit
Dim lf As Worksheet, ts As Worksheet, tf As Worksheet
Dim lrts&, lcts&, lrlf&
Dim collect As New Collection
Dim tabDep As Variant
Dim a%, lrcc%, i%, o%
Dim b As Byte
Dim plgflr As Range
Dim re As Range
Private Sub CommandButton1_Click()
Set ts = Worksheets("Tableau de synthèse")
Set tf = Worksheets("Table flore")
Dim plgflr As Range
Dim re As Range
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
Set plgflr = tf.Range("H1:H" & tf.Cells(Rows.Count, 1).End(xlUp).Row)
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
If re.Offset(, 2) = "France métropolitaine" And re.Offset(, -5) = "LRN" Then
.Cells(o, 4) = "Liste rouge française"
Else
.Cells(o, 4) = "-"
End If
If re.Offset(, 2) = "Alsace" Then
.Cells(o, 5) = "Liste rouge" & " " & "Alsace"
Else
.Cells(o, 5) = "-"
End If
Next
End With
End SubVous savez s'il est possible d'adapter ce code pour que la recherche se fasse sur tous les résultats trouvés ?
Je mets un document en PJ si vous voulez voir plus exactement ce qui se passe.
Bonne journée !
Salut Drosophile,
essaie comme ca (code non testé!)
Option Explicit
Dim lf As Worksheet, ts As Worksheet, tf As Worksheet
Dim lrts&, lcts&, lrlf&
Dim collect As New Collection
Dim tabDep As Variant
Dim a%, lrcc%, I%, o%
Dim b As Byte
Dim plgflr As Range
Dim re As Range
Private Sub CommandButton1_Click()
Set ts = Worksheets("Tableau de synthèse")
Dim plgflr As Range
Dim re As Range
Dim WS_Count As Integer, I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To WS_Count
Set tf = Worksheets(I)
Set plgflr = tf.Range("H1:H" & tf.Cells(Rows.Count, 1).End(xlUp).Row)
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
If re.Offset(, 2) = "France métropolitaine" And re.Offset(, -5) = "LRN" Then
.Cells(o, 4) = "Liste rouge française"
Else
.Cells(o, 4) = "-"
End If
If re.Offset(, 2) = "Alsace" Then
.Cells(o, 5) = "Liste rouge" & " " & "Alsace"
Else
.Cells(o, 5) = "-"
End If
Next
End With
Next I
End SubBonjour,
Merci pour la proposition, pour le moment j'ai l'erreur suivante : "Variable objet ou variable de bloc with non définie" mais je ne vois pas d'où elle peut provenir.
La PJ est absente alors je l'ajoute.
et comme ca?
Option Explicit
Dim lf As Worksheet, ts As Worksheet, tf As Worksheet
Dim lrts&, lcts&, lrlf&
Dim collect As New Collection
Dim tabDep As Variant
Dim a%, lrcc%, i%, o%
Dim b As Byte
Dim plgflr As Range
Dim re As Range
Private Sub CommandButton1_Click()
Set tf = Worksheets("Table flore")
Dim plgflr As Range
Dim re As Range
Dim i As Integer
Set plgflr = tf.Range("H1:H" & tf.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To ThisWorkbook.Worksheets.Count
Set ts = Worksheets(i)
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
If re.Offset(, 2) = "France métropolitaine" And re.Offset(, -5) = "LRN" Then
.Cells(o, 4) = "Liste rouge française"
Else
.Cells(o, 4) = "-"
End If
If re.Offset(, 2) = "Alsace" Then
.Cells(o, 5) = "Liste rouge" & " " & "Alsace"
Else
.Cells(o, 5) = "-"
End If
Next
End With
Next i
End SubBonsoir,
Peut-être faudrait-il passer par une autre procédure ?
Excel s'est arrêté de fonctionné cette fois. Il y a beaucoup de lignes à traiter ici
Bonjour,
J'ai fait un test en m'y prenant comme ça :
tf.Activate
With tf
For cib = 1 To lctf
If Cells(1, cib) = "LB_ADM_TR" Then
For c = 2 To lrtf
If Cells(c, cib) = "France métropolitaine" Then
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
If re.Offset(, -5) = "LRN" Then
.Cells(o, 4) = "Liste rouge française"
Else
.Cells(o, 4) = "-"
End If
Next o
End With
End If
Next c
For c = 2 To lrtf
If Cells(c, cib) = [keepregion] Then
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
If re.Offset(, -5) = "LRR" Then
.Cells(o, 4) = "Liste rouge" & " " & [keepregion]
Else
.Cells(o, 4) = "-"
End If
Next o
End With
End If
Next c
End If
Next cib
End With
ts.Activate[Keepregion] peut être changé par un nom de région
Ça fonctionne, mais ça a pris plus de 15 minutes pour 4 lignes... Du coup ça va pas le faire si j'ai 10 ou 15 lignes.
Vous savez s'il est possible de mieux tourner ce code ? Passer par une autre procédure ?
Bonsoir,
Une autre tentative, qui fonctionne mais qui prend à nouveau énormément de temps...
Set ts = Worksheets("Tableau de synthèse")
Set tf = Worksheets("Table flore")
Dim plgflr As Range
Dim re As Range
Set plgflr = tf.Range("H1:H" & tf.Cells(Rows.Count, 1).End(xlUp).Row)
lcts = ts.Cells(1, ts.Columns.Count).End(xlToLeft).Column
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
lctf = tf.Cells(1, tf.Columns.Count).End(xlToLeft).Column
lrtf = tf.Cells(Rows.Count, 1).End(xlUp).Row
'For i = 2 To ThisWorkbook.Worksheets.Count
' Set ts = Worksheets(i)
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
tf.Activate
With tf
tf.Range("K1:K" & lrtf).AutoFilter Field:=1, Criteria1:="France métropolitaine"
For cib = 1 To lctf
If Cells(1, cib) = "LB_ADM_TR" Then
For c = 2 To lrtf
ts.Activate
If re.Offset(, -5) = "LRN" Then
ts.Cells(o, 4) = "Liste rouge française"
Exit For
Else
ts.Cells(o, 4) = "-"
End If
Next c
Exit For
End If
Next cib
End With
Next o
End With
With ts
For o = 2 To lrts
Set re = plgflr.Find(.Cells(o, 1), lookat:=xlWhole)
tf.Activate
With tf
tf.Range("K1:K" & lrtf).AutoFilter Field:=1, Criteria1:=[keepregion]
For c = 2 To lrtf
ts.Activate
If re.Offset(, -5) = "LRR" Then
.Cells(o, 4) = "Liste rouge" & " " & [keepregion]
Exit Sub
Else
.Cells(o, 4) = "-"
End If
Next c
End With
Next o
End With
With tf.Cells(1, 1)
.Select
.AutoFilter
ts.Activateest ce possible de mettre le fichier avec la nouvelle macro et les données aussi pour mieux tester?
Bonsoir,
J'ai trouvé un moyen de rendre la recherche beaucoup plus rapide et elle cible mieux, a priori, le résultat recherché.
Par contre le résultat n'est pas toujours bon... haha donc je vais essayer de résoudre le problème et je posterai à la suite. Si je n'y parviens pas, je posterai mon code en expliquant où ça coince.
A plus tard
Bonjour,
Après plusieurs jours à tester, je ne parviens pas à faire fonctionner correctement mon code...
Le recherche ne vas jamais jusqu'au bout, une partie du code qui fonctionne ne fonctionne plus soudainement, une recherche qui donne nothing dans un cas et pas dans l'autre pour exactement la même chose...
Voici le code en question :
Sub RechData2()
Set ts = Worksheets("Tableau de synthèse")
Set tf = Worksheets("Table flore")
Dim plgflr As Range, re As Range, Plage As Range, plgflr1 As Range, re1 As Range
lcts = ts.Cells(1, ts.Columns.Count).End(xlToLeft).Column
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
lctf = tf.Cells(1, tf.Columns.Count).End(xlToLeft).Column
lrtf = tf.Cells(Rows.Count, 1).End(xlUp).Row
tf.Range("A2:L" & lrtf).AutoFilter Field:=10, Criteria1:="France métropolitaine"
For cib = 1 To lctf
If tf.Cells(1, cib) = "LB_ADM_TR" Then
Exit For
End If
Next cib
Set plgflr = tf.Range("H1:H" & lrtf)
'With ts
For o = 2 To lrts
Set re = plgflr.Find(ts.Cells(o, 1), lookat:=xlWhole)
Set Plage = tf.Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible) ' tf.UsedRange.SpecialCells(xlCellTypeVisible)'Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible).Rows
For Each c In Plage 'SpecialCells(xlVisible)
If re.Offset(, -5) = "LRN" Then
ts.Cells(o, 4) = re.Offset(, -1)
Exit For
Else
ts.Cells(o, 4) = "-"
'Exit For
End If
Next c
Next o
'With tf.Cells(1, 1)
' .AutoFilter
'End With
tf.Range("A1:L" & lrtf).AutoFilter Field:=10, Criteria1:=[keepregion]
Set plgflr1 = tf.Range("H1:H" & lrtf)
'With ts
For o = 2 To lrts
Set re1 = plgflr1.Find(ts.Cells(o, 1), lookat:=xlWhole)
Set Plage = tf.Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible)
For Each c In Plage
'If Not re1 Is Nothing Then
' ts.Cells(o, 5) = "-"
'Exit For
If re1.Offset(, -5) = "LRR" Then
ts.Cells(o, 5) = re1.Offset(, -1)
Exit For
Else
ts.Cells(o, 5) = "-"
End If
End If
Next c
Next o
With tf.Cells(1, 1)
.AutoFilter
End With
End SubLa recherche est beaucoup plus rapide maintenant, mais elle ne donne pas un bon résultat.
Je joins un document de travail avec le code, si vous avez une idée..
Bonne journée !
Bonsoir,
Je suis finalement parvenu à faire fonctionner le code !
Le voici :
Option Explicit
Dim lf As Worksheet, ts As Worksheet, tf As Worksheet
Dim lrts&, lcts&, lrlf&, lclf&, lrtf&, lctf&
Dim collect As New Collection
Dim tabDep As Variant, c As Variant
Dim a%, lrcc%, i%, o%, cib%
Dim b As ByteSet ts = Worksheets("Tableau de synthèse")
Set tf = Worksheets("Table flore")
Dim plgflr As Range, re As Range, Plage As Range, plgflr1 As Range, re1 As Range
lcts = ts.Cells(1, ts.Columns.Count).End(xlToLeft).Column
lrts = ts.Cells(Rows.Count, 1).End(xlUp).Row
lctf = tf.Cells(1, tf.Columns.Count).End(xlToLeft).Column
lrtf = tf.Cells(Rows.Count, 1).End(xlUp).Row
tf.Range("A2:L" & lrtf).AutoFilter Field:=10, Criteria1:="France métropolitaine"
For cib = 1 To lctf
If tf.Cells(1, cib) = "LB_ADM_TR" Then
Exit For
End If
Next cib
Set plgflr = tf.Range("H1:H" & lrtf)
'With ts
For o = 2 To lrts
Set re = plgflr.Find(ts.Cells(o, 1), lookat:=xlWhole)
Set Plage = Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible) ' tf.UsedRange.SpecialCells(xlCellTypeVisible)'Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible).Rows
For Each c In Plage 'SpecialCells(xlVisible)
If re Is Nothing Then
ts.Cells(o, 4) = "-"
Exit For
Else
If re.Offset(, -5) = "LRN" Then
ts.Cells(o, 4) = re.Offset(, -1)
Exit For
Else
ts.Cells(o, 4) = "-"
End If
End If
Next c
Next o
tf.Range("A1:L" & lrtf).AutoFilter Field:=10, Criteria1:=[keepregion]
Set plgflr1 = tf.Range("H1:H" & lrtf)
For o = 2 To lrts
Set re1 = plgflr1.Find(ts.Cells(o, 1), lookat:=xlWhole)
Set Plage = Range(Cells(2, cib), Cells(lrtf, cib)).SpecialCells(xlCellTypeVisible)
For Each c In Plage
If re1 Is Nothing Then
ts.Cells(o, 5) = "-"
Exit For
Else
If re1.Offset(, -5) = "LRR" Then
ts.Cells(o, 5) = re1.Offset(, -1)
Exit For
Else
ts.Cells(o, 5) = "-"
End If
End If
Next c
Next o
With tf.Cells(1, 1)
.AutoFilter
End With
End SubCette discussion peut donc être classée comme résolue
Merci de votre aide