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

  • Initiateur de la discussion Initiateur de la discussion Ron2cuir
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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
 
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:
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+
 

Pièces jointes

Dernière édition:
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+
 

Pièces jointes

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+
 
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)
 
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.
 

Pièces jointes

Dernière édition:
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+

 

Pièces jointes

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.
 

Pièces jointes

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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour