XL 2019 recherche de données d'un tableau dans un autre tableau

[marc01]

Bonjour
je bute sur une recherche si quelqu'un peut m'aider...
j'ai un premier tableau A composé de 15 colonnes et environ 48000 ligne
j'ai un deuxieme tableau B composé d'une seule colonne et d'environ 2000 cellules dont le contenu est toujours diffèrent
je cherche a retrouver dans mon tableau A en bout de chaque ligne si le contenu des cellules de mon tableau B sont presentent et si oui d'inscrire la correspondance
j'ai joint un petit fichier expliquant un exemple

merci d'avance à la communauté
marc
cdt

 

[Calvus]

Bonsoir et bienvenue,

je cherche a retrouver dans mon tableau A en bout de chaque ligne si le contenu des cellules de mon tableau B sont presentent et si oui d'inscrire la correspondance

Selon quels critères ?????

A+

 

[marc01]

Bonjour
dans mon exemple, j'aurai du dire que pour simplifier j'avais tout mis sur la meme feuille
je cherche à retrouver les items "papa ou maman, ou frere etc.…" dans chacune des listes horizontales

merci d'avance
marc

 

[merinos]

Salut Marc01,
Bonjour la Forum,

C'est super simple avec un query...

Juste une question: Que ce passe t'il si on a 2 bonne reponces sur une ligne (voir ligne ajoutée).

Merinos

 

[marc01]

Bonjour
merci tout d'abord
je n'aurai pas deux reponses sur la meme ligne, c'est a dire par exemple je n'aurai pas "papa " et "maman" sur la même ligne
marc
cdt

 

[Calvus]

Bonjour,

Quelle perte de temps quand les demandes ne sont pas claires !!!

Prendre 5 ou 10 minutes pour rédiger clairement un message en fera économiser énormément pour celui qui tente d'apporter une solution.
Le nombre de réponses sera également plus grand, puisque les gens auront compris clairement la demande dès le début, et ne se lasseront pas d'essayer de deviner ce que le demandeur a dans la tête...

Ceci dit, voici ce qui devrait, je l'espère, répondre à la demande. En 2 versions.

Un bouton "Cacher les lignes" permettant de cacher les lignes où ne figurent pas les items cités en colonne N.
Un bouton permettant de tout ré-afficher.

Version 2 :
Deux boutons permettant l'écriture de tous les items trouvés les uns en dessous des autres. Je crois que c'est ce qui était demandé.
Le premier bouton Ecriture permet l'écriture des items en dur dans le code, mais pas terrible comme solution.
Le bouton Dynamique prend en compte tous les items inscrits en colonne N.

Le fait de devoir inscrire une même valeur plusieurs fois nécessite l'ajout d'une colonne pour la création du dictionnaire.
C'est une simple liste numérotée (colonne M)

Les codes :

Option Explicit

Sub Filtre_Famille()
Dim i As Integer, j As Integer
Dim flag As Boolean

For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
flag = True
    For j = 1 To 9
        If LCase(Cells(i, j)) = "papa" Or LCase(Cells(i, j)) = "maman" Or LCase(Cells(i, j)) = "frere" _
        Or LCase(Cells(i, j)) = "soeur" Or Cells(i, j) = "&23" Then
flag = False
        End If
    Next j
If flag Then Cells(i, j).EntireRow.Hidden = True
Next i
End Sub

Sub Afficher_Tout()
Dim i As Integer, j As Integer

Application.ScreenUpdating = False
For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
    Rows(i).EntireRow.Hidden = False
Next i
Application.ScreenUpdating = True
End Sub

Sub Ecriture()
Dim i As Integer, j As Integer, k As Integer

For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To 9
            If LCase(Cells(i, j)) = "papa" Or LCase(Cells(i, j)) = "maman" Or LCase(Cells(i, j)) = "frere" _
            Or LCase(Cells(i, j)) = "soeur" Or Cells(i, j) = "&23" Then
                Range("K" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(i, j)
                    Exit For
            End If
    Next j
Next i
End Sub
Sub mondico()

Dim f As Worksheet, mondico, BD(), tablo, i As Integer
Set f = Sheets("Feuil1")
Set tablo = f.Range("M5:M" & f.Range("M" & Rows.Count).End(3).Row)
BD = tablo.Value
Set mondico = CreateObject("Scripting.Dictionary")
    mondico.CompareMode = vbTextCompare
        For i = LBound(BD) To UBound(BD)
            If Not mondico.Exists(BD(i, 1)) Then mondico.Add Cells(i + 4, 13), Cells(i + 4, 14)
        Next

Dim c, j As Integer

For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
    For Each c In mondico.keys
        For j = 1 To 9
            If Cells(i, j) = mondico(c) Then
                Range("K" & Rows.Count).End(xlUp).Offset(1, 0) = mondico(c)
                    i = i + 1
                Exit For
            End If
        Next j
    Next c
Next i
Set mondico = Nothing
End Sub

Voilà.

A+

 

[marc01]

Bonjour
Je voudrai tout d abord m excuser pour ce qui vous a manqué dans ma description, je me méfierai à l’avenir de ce qui me paraissait une évidence (everyday is a school day)
Puis, le plus important, je voudrai remercier celles et ceux du forum qui ont passé du temps pour essayer de m aider et à vous qui m avait trouvé celle ci
J ai découvert par hazard ce site, depuis j y apprend
Merci à vous
Très bon week end

 

[marc01]

Avez

Bonjour
Je voudrai tout d abord m excuser pour ce qui vous a manqué dans ma description, je me méfierai à l’avenir de ce qui me paraissait une évidence (everyday is a school day)
Puis, le plus important, je voudrai remercier celles et ceux du forum qui ont passé du temps pour essayer de m aider et à vous qui m avait trouvé celle ci
J ai découvert par hazard ce site, depuis j y apprend
Merci à vous
Très bon week end

 

[marc01]

Avez

 

[Calvus]

Bonsoir Marc01, le forum,

Avez

Pas de problème


Est ce que ça fonctionne ? C"est ce que vous vouliez ?

Bonne soirée.

 

[merinos]

Salut @marc01 ,

As tu testé la solution? il suffit de "rafraichir " le tableau "Presents" d'un click droit.

Le propre des query est de n'etre ni une formule ni une macro... et donc si on ne sait pas ou chercher, on ne trouve RIEN....