XL 2016 Recherche en fonction d’une série de nombres

cmdavid

XLDnaute Occasionnel
Bonjour à tous,

Je cherche une formule pour en cherchant dans un tableau une série de nombre (179+180+183), j’ai le résultat correspondant au ligne 179, 180, 183, ect.

Je précise que les colonnes du tableau (C-E-F-H-I-J-K) en fonction de la série de nombre contiendront les mêmes informations, seul le pays peut être différent. Voir fichier joint.

Merci pour votre aide,

Cordialement,
 

Pièces jointes

  • rech nb.xlsx
    11.6 KB · Affichages: 7
Solution
Bonjour cmdavid, Lolote83, le forum,

Voyez le fichier joint et cette fonction VBA, à placer dans un module standard :
VB:
Function Rech_Nb$(tableau As Range, ref$, titrecol$, titrecolmult$)
Dim r As Range, P As Range, j%, n As Byte, i&
ref = "+" & ref & "+" 'encadrement
For Each r In tableau.Rows
    If InStr(ref, "+" & r.Cells(1) & "+") Then Set P = Union(IIf(P Is Nothing, r, P), r)
Next
If P Is Nothing Then Exit Function
If titrecol Like titrecolmult & "*" Then
    j = Application.Match(Left(titrecol, Len(titrecol) - 1), tableau.Rows(0), 0)
    n = Val(Right(titrecol, 1))
    For Each P In Intersect(P, tableau.Columns(j))
        i = i + 1
        If i = n Then Rech_Nb = P: Exit For
    Next
Else
    j =...

Lolote83

XLDnaute Barbatruc
Bonjour @cmdavid
Voici ton fichier en retour (voir feuil2)
En fait au lieu de concaténer les lignes souhaitées, j'ai mis plusieurs saisies possible.
En espérant que cela pourra correspondre à tes attentes
@+ Lolote83
 

Pièces jointes

  • Copie de CMDAVID - Recherche mutilple.xlsx
    17.2 KB · Affichages: 3

cmdavid

XLDnaute Occasionnel
Bonjour Lolote83,
je comprend ce que vous avez fait, mais mon problème est que la recherche doit partir de, exemple : 179+180+183
question, existe il la possibilité de séparer la série de chiffre, dans les conditions ou on peut avoir : 1+12+163 ...
et ainsi utiliser votre solution.
merci pour votre réponse
 

job75

XLDnaute Barbatruc
Bonjour cmdavid, Lolote83, le forum,

Voyez le fichier joint et cette fonction VBA, à placer dans un module standard :
VB:
Function Rech_Nb$(tableau As Range, ref$, titrecol$, titrecolmult$)
Dim r As Range, P As Range, j%, n As Byte, i&
ref = "+" & ref & "+" 'encadrement
For Each r In tableau.Rows
    If InStr(ref, "+" & r.Cells(1) & "+") Then Set P = Union(IIf(P Is Nothing, r, P), r)
Next
If P Is Nothing Then Exit Function
If titrecol Like titrecolmult & "*" Then
    j = Application.Match(Left(titrecol, Len(titrecol) - 1), tableau.Rows(0), 0)
    n = Val(Right(titrecol, 1))
    For Each P In Intersect(P, tableau.Columns(j))
        i = i + 1
        If i = n Then Rech_Nb = P: Exit For
    Next
Else
    j = Application.Match(titrecol, tableau.Rows(0), 0)
    Rech_Nb = P(1, j)
End If
End Function
Formule en N3 à tirer à droite et vers le bas :
Code:
=Rech_Nb(Tableau1;$M3;N$1;"Desti")
Nota : le tableau source est structuré.

Notez l'indexation des titres en Q1:V1.

A+
 

Pièces jointes

  • rech nb(1).xlsm
    21.3 KB · Affichages: 5

Lolote83

XLDnaute Barbatruc
Re bonjour,
Sinon, dans le même esprit que @job75 (que je salue au passage), une autre fonction personnalisée
VB:
Function Recherche2(xRech, xChps)
    xDecoupe = Split(xRech, "+")
    For Each xCell In Range("N1:Z1")
        xResult = Empty
        If xCell.Value = xChps Then
            If xCell Like "Desti*" Then
                xNum = Val(Right(xCell.Value, 1)) - 1
                If xNum <= UBound(xDecoupe) Then
                    xResult = Application.Index(Range("Tableau1[Desti]"), Application.Match(Val(xDecoupe(xNum)), Range("Tableau1[REF]"), 0))
                End If
            Else
                xResult = Application.Index(Range("Tableau1[" & xChps & "]"), Application.Match(Val(xDecoupe(0)), Range("Tableau1[REF]"), 0))
            End If
        End If
        If xResult <> Empty Then
            Recherche2 = xResult
            Exit For
        End If
    Next xCell
End Function

Fonction que tu appelles dans la cellule N3 =Recherche2($M3;N$1) puis tirer à droite et vers le bas
@+ Lolote83
 

job75

XLDnaute Barbatruc
Ce n'est pas fini.

Cette macro dans le code de la feuille calcule les valeurs en colonne M et remplit le tableau des résultats :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, tablo, ncol%, resu(), i, x$, j%, nn&, n&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [Tableau1] 'tableau structuré, matrice, plus rapide
ncol = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 1 To UBound(tablo)
    x = ""
    For j = 2 To ncol
        If j <> 3 And j <> 6 Then 'Date et Desti exclus
            x = x & Chr(1) & tablo(i, j) 'concaténation
        End If
    Next j
    If d.exists(x) Then
        nn = d(x)
        resu(nn, 1) = resu(nn, 1) & "+" & tablo(i, 1)
    Else
        n = n + 1
        d(x) = n 'mémorise la ligne
        resu(n, 1) = tablo(i, 1)
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
With [M3]
    If n Then
        .Resize(n) = resu
        .Offset(, 1).Resize(n, 13) = "=Rech_Nb(Tableau1,RC" & .Column & ",R1C,""Desti"")"
        .Resize(n, 14).Borders.Weight = xlThin 'bordures
    End If
    With .Offset(n).Resize(Rows.Count - n - .Row + 1, 14)
        .ClearContents 'RAZ en dessous
        .Borders.LineStyle = xlNone
    End With
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Elle se déclenche quand on modifie ou valide une cellule quelconque.
 

Pièces jointes

  • rech nb(2).xlsm
    26.2 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour cmdavid,

Toujours pas fini.

La macro de mon post #7 s'exécute chez moi en 0,14 seconde, c'est relativement lent.

C'est dû à la fonction Rech_Nb qui pour chaque cellule redétermine la plage correspondant au texte en colonne M.

Dans ce fichier (3) j'ai introduit la colonne intermédiaire N avec les adresses des plages correspondantes.

Cette colonne N pourra être masquée.

La macro s'exécute maintenant en 0,028 seconde, c'est 5 fois plus rapide.

A+
 

Pièces jointes

  • rech nb(3).xlsm
    29.9 KB · Affichages: 1

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 910
Membres
101 837
dernier inscrit
Ugo