equiv ou recherchev (cellules du champ de recherche comprises entre 1 et 12000car)

Ron2cuir

XLDnaute Nouveau
Bonjour,
petit nouveau XLD!
Désolé j'ai confondu discussion et conversation!!!
Ces fonctions ne prennent en compte que 256 car des cellules de champs (6000lignes).
qui a déja trouvé une solution (même avec vba) pour pallier cet inconvénient ?

Le retour doit être: numéro de ligne dans la table.
Merci de votre aide
 

Ron2cuir

XLDnaute Nouveau
Bonjour
l'argument peut exister dans plusieurs cellules du champ K (Feld)
voila ce que j'ai fait:
'*************************************************************************
Function EquivP(Argum, Feld As Range)
Dim OkAddress, Cold, Serche
'Cold = Feld.Address 'pour tester
Cold = Feld.Row - 1
Set Serche = Feld.Find(Argum, LookIn:=xlValues)
If Not Serche Is Nothing Then OkAddress = Serche.Row - 1 - Cold
EquivP = OkAddress
Set Serche = Nothing
End Function
'*************************************************************************
dans une autre feuille ma formule d'appel:
en K4 =1 ligne de haut de ma base 3500 lignes
en K5 =EQUIVp(Argum;INDIRECT("BaseImaJ!K"&MAX($K4+1;1)&":K3500"))
en K6 =EQUIVp(Argum;INDIRECT("BaseImaJ!K"&MAX($K5+1;1)&":K3500"))
ETC... sur 300 lignes
ça fonctionne presque! sauf que:
-Le premier élément trouvé donne un numéro de ligne -1 ????
-les éléments suivants ok
-le(s) dernier(s) élément(s) non trouvé(s) reprennent le numéro de ligne du dernier trouvé
J'espère être clair!
Merci
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Ron2cuir, bienvenue sur XLD,

Effectivement le nombre maximum de caractères est 255 pour les fonctions EQUIV RECHERCHEV et RECHERCHEH.

Voyez le fichier joint et ces 3 fonctions VBA pour lesquelles il n'y a plus de limite :
Code:
Option Compare Text 'la casse est ignorée

Function EquivPlus(X As Variant, R As Range) As Variant
If Not IsEmpty(X) And (R.Rows.Count = 1 Or R.Columns.Count = 1) Then
  Dim P As Range, i&
  Set P = Intersect(R, Application.Caller.Parent.UsedRange)
  If Not P Is Nothing Then
    For i = 1 To P.Count
      If P(i) = X Then
        If R.Columns.Count = 1 Then EquivPlus = i + P.Row - R.Row _
          Else EquivPlus = i + P.Column - R.Column
        Exit Function
      End If
    Next
  End If
End If
EquivPlus = [#N/A]
End Function

Function RechercheVPlus(X As Variant, R As Range) As Variant
If Not IsEmpty(X) Then
  Set R = Intersect(R, Application.Caller.Parent.UsedRange)
  If Not R Is Nothing Then
    Dim i&
    For i = 1 To R.Rows.Count
      If R(i, 1) = X Then RechercheVPlus = R(i, R.Columns.Count): Exit Function
    Next
  End If
End If
RechercheVPlus = [#N/A]
End Function

Function RechercheHPlus(X As Variant, R As Range) As Variant
If Not IsEmpty(X) Then
  Set R = Intersect(R, Application.Caller.Parent.UsedRange)
  If Not R Is Nothing Then
    Dim i%
    For i = 1 To R.Columns.Count
      If R(1, i) = X Then RechercheHPlus = R(R.Rows.Count, i): Exit Function
    Next
  End If
End If
RechercheHPlus = [#N/A]
End Function
A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Si je ne me trompe pas EquivPlus(X;R) donne les même résultats que EQUIV(X;R;0).

Ce n'est pas tout à fait le cas pour RechercheVPlus et RechercheHPlus, ce serait trop compliqué.

A+
 

job75

XLDnaute Barbatruc
Re,

Je viens de revoir les fonctions RechercheVPlus et RechercheHPlus :
Code:
Function RechercheVPlus(X As Variant, R As Range) As Variant
Dim lig As Variant
lig = EquivPlus(X, R.Columns(1))
If IsNumeric(lig) Then RechercheVPlus = R(lig, R.Columns.Count) Else RechercheVPlus = lig
End Function

Function RechercheHPlus(X As Variant, R As Range) As Variant
Dim col As Variant
col = EquivPlus(X, R.Rows(1))
If IsNumeric(col) Then RechercheHPlus = R(R.Rows.Count, col) Else RechercheHPlus = col
End Function
Maintenant elles donnent les mêmes résultats que RECHERCHEV(....;0) et RECHERCHEH(....;0).

Quel que soit le UsedRange.

Fichier (2).

A+
 

Fichiers joints

Ron2cuir

XLDnaute Nouveau
Re,

Je viens de revoir les fonctions RechercheVPlus et RechercheHPlus :
Code:
Function RechercheVPlus(X As Variant, R As Range) As Variant
Dim lig As Variant
lig = EquivPlus(X, R.Columns(1))
If IsNumeric(lig) Then RechercheVPlus = R(lig, R.Columns.Count) Else RechercheVPlus = lig
End Function

Function RechercheHPlus(X As Variant, R As Range) As Variant
Dim col As Variant
col = EquivPlus(X, R.Rows(1))
If IsNumeric(col) Then RechercheHPlus = R(R.Rows.Count, col) Else RechercheHPlus = col
End Function
Maintenant elles donnent les mêmes résultats que RECHERCHEV(....;0) et RECHERCHEH(....;0).

Quel que soit le UsedRange.

Fichier (2).

A+
 

Ron2cuir

XLDnaute Nouveau
Bonjoir (certains s'y reconnaîtront)
Voici ma version definitive (en test)

Function EquivP(Argum, Feld As Range)
Dim OkAddress, Cold, Serche
Cold = Feld.Row - 1
Set Serche = Feld.Find(Argum, LookIn:=xlValues)
If Not Serche Is Nothing Then
OkAddress = Serche.Row - 1 - Cold
If OkAddress = 0 Then EquivP = [#N/A]: GoTo Endy
End If
EquivP = OkAddress
Endy:
Set Serche = Nothing
End Function
Merci à Job75 pour les solutions proposées
Ron2Cuir (ex rama de la bande Misange, JPS, MichDenis,J@C)
 

job75

XLDnaute Barbatruc
Re,

Avec un tableau VBA EquivPlus est nettement plus rapide qu'avec toute autre méthode :
Code:
Function EquivPlus(X As Variant, R As Range) As Variant
If Not IsEmpty(X) And (R.Rows.Count = 1 Or R.Columns.Count = 1) Then
  Dim P As Range, tablo, i&
  Set P = Intersect(R, Application.Caller.Parent.UsedRange)
  If Not P Is Nothing Then
    If R.Rows.Count = 1 Then
      tablo = P.Resize(2) 'au moins 2 éléments
      For i = 1 To UBound(tablo, 2)
        If tablo(1, i) = X Then EquivPlus = i + P.Column - R.Column: Exit Function
      Next
    Else
      tablo = P
      For i = 1 To UBound(tablo)
        If tablo(i, 1) = X Then EquivPlus = i + P.Row - R.Row: Exit Function
      Next
    End If
  End If
End If
EquivPlus = [#N/A]
End Function
Fichier (3).

Bonne nuit.
 

Fichiers joints

Dernière édition:

Ron2cuir

XLDnaute Nouveau
Bonjour Job75
je n'ai pas réussi à m'en sortir avec EquivPlus
mais je te joins mon classeur avec mon bazar (ça fonctionne)
Salutations
 

Fichiers joints

job75

XLDnaute Barbatruc
Re,

Effectivement il faut corriger la fonction EquivPlus pour qu'elle fonctionne :

- sur n'importe quelle feuille en remplaçant simplement Application.Caller par R

- avec les caractères génériques * et ? en remplaçant = X par Like X
Code:
Function EquivPlus(X As Variant, R As Range) As Variant

If Not IsEmpty(X) And (R.Rows.Count = 1 Or R.Columns.Count = 1) Then
  Dim P As Range, tablo, i&
  Set P = Intersect(R, R.Parent.UsedRange)
  If Not P Is Nothing Then
    If R.Rows.Count = 1 Then
      tablo = P.Resize(2) 'au moins 2 éléments
      For i = 1 To UBound(tablo, 2)
        If tablo(1, i) Like X Then EquivPlus = i + P.Column - R.Column: Exit Function
      Next
    Else
      tablo = P
      For i = 1 To UBound(tablo)
        If tablo(i, 1) Like X Then EquivPlus = i + P.Row - R.Row: Exit Function
      Next
    End If
  End If
End If
EquivPlus = [#N/A]
End Function
Fichier (4).

A+

 

Fichiers joints

Ron2cuir

XLDnaute Nouveau
Merci
rapidité et efficacité chapeau!!
EquivPlus OK (me servira surtout dans le cas où l'argument est supérieur à 255 car)
car avec find apparemment c'est limité à 255 car (j'ai excel 10 et win 10)
Salutations
 

job75

XLDnaute Barbatruc
Re,

Au vu de votre fichier Ron2cuir je me rends compte que votre problème se résume à déterminer si un texte x existe dans un texte y.

Et cela quel que soit le nombre de caractères de x et y.

La fonction VBA est alors très simple :
Code:
Option Compare Text 'la casse est ignorée

Function TexteExiste(x$, y$) As Boolean
TexteExiste = y Like "*" & x & "*"
End Function
On peut ensuite l'utiliser comme critère pour le filtre avancé :
Code:
Private Sub CommandButton1_Click()
If CommandButton1.Caption = "Filtrer" Then
  [E2] = "=TexteExiste(D$1,A2)" 'critère de filtrage
  [A1].CurrentRegion.AdvancedFilter xlFilterInPlace, [E1:E2]
  [E2] = ""
CommandButton1.Caption = "Afficher"
Else
  If FilterMode Then ShowAllData
  CommandButton1.Caption = "Filtrer"
End If
End Sub
Voyez le fichier joint.

Vous noterez que le filtre fonctionne bien si l'on entre en D1 la formule =A2

Bonne fin de soirée.
 

Fichiers joints

Ron2cuir

XLDnaute Nouveau
Bonjour
Ce que je veux obtenir ce sont tous les numéros de ligne (limités à 300) d'une base de 6000 lignes où l'argument a été trouvé. Ces numéros servent ensuite à des intersections pour une répartion par nature d'info...avec un userform.
Merci de m'avoir fait découvrir de nouvelles fonctionnalités.
Il est vrai que l'exemple fourni ne faisait pas apparaître toute la problématique.
Salutations
 

job75

XLDnaute Barbatruc
Bonjour Ron2cuir, le forum,
Ce que je veux obtenir ce sont tous les numéros de ligne (limités à 300) d'une base de 6000 lignes où l'argument a été trouvé.
Eh bien on y arrive, il suffisait de le dire.

Utilisez donc cette fonction qui renvoie une matrice (vecteur colonne) :
Code:
Option Compare Text 'la casse est ignorée

Function ListeLignes(x$, R As Range, limite&)
Dim a(), P As Range, decal&, tablo, i&, n&
ReDim a(1 To limite, 1 To 1)
If x <> "" Then
  Set P = Intersect(R.Columns(1), R.Parent.UsedRange)
  If Not P Is Nothing Then
    x = "*" & x & "*"
    decal = P.Row - R.Row
    tablo = P.Resize(, 2) 'au moins 2 éléments
    For i = 1 To UBound(tablo)
      If tablo(i, 1) Like x Then
          n = n + 1
          If n > limite Then Exit For
          a(n, 1) = i + decal
      End If
    Next
  End If
End If
For i = n + 1 To limite 'complète la liste si nécessaire
  a(i, 1) = ""
Next
ListeLignes = a 'vecteur colonne
End Function
Fichier joint, la fonction est entrée matriciellement en Feuil1 dans la plage C6:C305.

A+
 

Fichiers joints

Dernière édition:

Ron2cuir

XLDnaute Nouveau
Heu!!
je me suis aperçu que je vous tutoyais mais après ça le vouvoiement de rigueur.
1) Je vous prie de bien vouloir m'excuser.
2)Exactement ce que je souhaitais... et Job75 l'a fait.
Très sincères salutations (sans mièvreries)
A+
 

job75

XLDnaute Barbatruc
Re,

J'ai légèrement simplifié la fin de la fonction, le test If n < limite Then était inutile.

Le calcul est rapide : 0,09 seconde pour rechercher g?n?ral sur 3361 lignes.

PS : le tutoiement ne me gêne nullement mais je suis de la vieille école :)

A+
 

job75

XLDnaute Barbatruc
Re,

Pour terminer, puisque vous avez parlé d'UserForm, voyez le fichier joint avec ce code :
Code:
Option Compare Text 'la casse est ignorée
Dim P As Range 'mémorise la variable

Private Sub ListBox1_Click()
TextBox2 = P(ListBox1.List(ListBox1.ListIndex, 0))
TextBox2.SetFocus: TextBox2.SelStart = 0: ListBox1.SetFocus
End Sub

Private Sub TextBox1_Change()
Dim limite&, x$, tablo, i&, n&
limite = 300 'modifiable
ListBox1.Clear: TextBox2 = "" 'RAZ
Set P = Intersect(Feuil1.[A:A], Feuil1.UsedRange) 'Feuil1 => CodeName
If TextBox1 = "" Or P Is Nothing Then Exit Sub
x = "*" & TextBox1 & "*"
tablo = P.Resize(, 2) 'au moins 2 éléments
For i = 2 To UBound(tablo)
  If tablo(i, 1) Like x Then
    ListBox1.AddItem i 'numéro de ligne dans la 1ère colonne
    ListBox1.List(n, 1) = Left(tablo(i, 1), 100)
    n = n + 1
    If n > limite Then Exit For
  End If
Next
End Sub
A+
 

Fichiers joints

Discussions similaires


Haut Bas