recherche d'un terme sous plusieurs onglets (et/ou) plusieurs classeurs et récupération de la colonne et ligne

**Fleur59** · 02/07/2020, 21h41

Bonjour à tous,
de nouveau sur une idée épineuse, je sollicite vos neurones en ébullition
fichier joint
dans chaque fichier (1 en français et l'autre en anglais - exactement même structure)
j'ai une série de termes regroupés pour former des familles dans un tableau double entrée
je souhaite dans un 3° fichier, lancer une recherche d'un terme dans ces 2 fichiers et récupérer la (ou les, normalement pas de doublon mais....)
donc récupérer la famille qui correspond à "feuille" & 4° digit (ligne)& 5° digit(colonne): exemple CIRE = YK031; POULIE =YK761...
par macro ou formule, pas de préférence; je penses que l'on peut même avoir des cellules de recherches distinctes pour le fichier français et le fichier anglais
Merci d'avance pour votre aide
Prenez bien soin de vous et de vos proches,
Fleur59

**ARTURO83** · 03/07/2020, 06h56

Bonjour,

Voici une proposition, ouvrez les 3 classeurs dans la même session excel.
Comme je n'ai pas le nom des classeurs ni leur emplacement, allez sur le classeur "Résultats", faites ALT + F11 pour accéder au code et remplacez les noms des classeurs par les vrais noms.
Allez sur le classeur "Résultats", Cliquez sur le bouton, et saisissez une valeur à rechercher.
le résultat s'affiche soit dans la colonne "Français" ou" Anglais".

le classeur "Résultats"
Pièce jointe 574282

Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub Recherche()
    Dim Message, Titre, ValeurRecherchee
    Application.ScreenUpdating = False
    Dim Col_Fr As Long, Col_An As Long, Lig_Res As Long
    Dim c As Long, Cpt As Long, i As Long
    Dim Lig_v As Long, Col_v As Long
    Dim v As Object
 
    Message = "Quelle est la valeur recherchée"
    Titre = "Valeur recherchée"
    ValeurRecherchee = UCase(InputBox(Message, Titre)) 'Demande quelle est la valeur à rechercher
    Col_Fr = 2 'colonne des résultats pour le fichier français
    Col_An = 3 'colonne des résultats pour le fichier anglais
 
    ReDim Valeur(0) As String
    For c = 1 To 2
        If c = 1 Then Classeur = "Français.xlsx" Else Classeur = "Anglais.xlsx"
        Windows(Classeur).Activate 'on active le classeur
        For i = 1 To Sheets.Count 'on passe toutes les feuilles en revue
            Set v = Sheets(i).Cells.Find(ValeurRecherchee, lookat:=xlWhole) 'on cherche la valeur
            If Not v Is Nothing Then 'si la valeur est trouvée
                Lig_v = Cells(v.Row, "A").MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en colonne A
                Col_v = Cells(2, v.Column).MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en ligne 2
                Valeur(Cpt) = Sheets(i).Name & Lig_v & Col_v 'on associe le nom de la feuille avec celles de la ligne et de la colonne
                Cpt = Cpt + 1 'incrémentation du compteur des valeurs trouvées
                ReDim Preserve Valeur(Cpt)
            End If
        Next i
        Windows("Resultats.xlsm").Activate
        If Cpt <> 0 Then
 
            If c = 1 Then
                Lig_Res = Sheets("Res").Range("B" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "français"
                Sheets("Res").Cells(Lig_Res, Col_Fr).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            Else
                Lig_Res = Sheets("Res").Range("C" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "anglais"
                Sheets("Res").Cells(Lig_Res, Col_An).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            End If
            Sheets("Res").Cells(Lig_Res, "A") = ValeurRecherchee
        End If
    Next c
    Set v = Nothing
End Sub

Cdlt

**Fleur59** · 03/07/2020, 10h28

Bonjour Arturo83;
Superbe!
petite amélioration si possible, la recherche se fait sur les champs entiers.
est-il possible de chercher à l'intérieur des champs? si je cherche "Steel", je ne trouve rien
Merci de votre aide déjà bien précieuse
Fleur59

**Menhir** · 03/07/2020, 11h12

Changer lookat:=xlWhole par lookat:=xlPart.
Lire ça :
https://docs.microsoft.com/fr-fr/off...cel.range.find
https://docs.microsoft.com/fr-fr/off...excel.xllookat

**Fleur59** · 03/07/2020, 11h49

Youhou Merci Menhir
dans la colonne A s'écrit la valeur recherchée, pourrais-je avoir la valeur trouvée?
demande la Fleur exigeante
Merci d'avance
Fleur59

**ARTURO83** · 03/07/2020, 19h34

Bonsoir,

Voici la modification demandée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub Recherche()
    Dim Message, Titre, ValeurRecherchee
    Application.ScreenUpdating = False
    Dim Col_Fr As Long, Col_An As Long, Lig_Res As Long
    Dim c As Long, Cpt As Long, i As Long
    Dim Lig_v As Long, Col_v As Long
    Dim v As Object
 
    Message = "Quelle est la valeur recherchée"
    Titre = "Valeur recherchée"
    ValeurRecherchee = UCase(InputBox(Message, Titre)) 'Demande quelle est la valeur à rechercher
    Col_Fr = 2 'colonne des résultats pour le fichier français
    Col_An = 3 'colonne des résultats pour le fichier anglais
 
    ReDim Valeur(0) As String
    ReDim Trouve(0) As String
    For c = 1 To 2
        If c = 1 Then Classeur = "Français.xlsx" Else Classeur = "Anglais.xlsx"
        Windows(Classeur).Activate 'on active le classeur
        For i = 1 To Sheets.Count 'on passe toutes les feuilles en revue
            'Cpt = ""
            Set v = Sheets(i).Cells.Find(ValeurRecherchee, LookIn:=xlValues, lookat:=xlPart) 'on cherche la valeur
            If Not v Is Nothing Then 'si la valeur est trouvée
                Lig_v = Sheets(i).Cells(v.Row, "A").MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en colonne A
                Col_v = Sheets(i).Cells(2, v.Column).MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en ligne 2
                Valeur(Cpt) = Sheets(i).Name & Lig_v & Col_v 'on associe le nom de la feuille avec celles de la ligne et de la colonne
                Trouve(Cpt) = Sheets(i).Cells(v.Row, v.Column) 'on récupère la valeur recherchée
                Cpt = Cpt + 1 'incrémentation du compteur des valeurs trouvées
                ReDim Preserve Valeur(Cpt)
                ReDim Preserve Trouve(Cpt)
            End If
        Next i
        Windows("Resultats.xlsm").Activate
        If Cpt <> 0 Then
            If c = 1 Then
                Lig_Res = Sheets("Res").Range("A" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "français"
                Sheets("Res").Cells(Lig_Res, Col_Fr).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            Else
                Lig_Res = Sheets("Res").Range("A" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "anglais"
                Sheets("Res").Cells(Lig_Res, Col_An).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            End If
            'Sheets("Res").Cells(Lig_Res, "A") = ValeurRecherchee
            Sheets("Res").Cells(Lig_Res, 1).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Trouve) 'restitution des valeurs dans le classeur "Résultats"
            Cpt = 0
        End If
    Next c
    Set v = Nothing
End Sub

Cdlt

**Fleur59** · 06/07/2020, 14h18

Bonjour à Tous
Merci pour cette grande avancée, mais il semble que pour chaque feuille la recherche s'arrête à la première occurrence trouvée
Merci encore pour votre aide précieuse
Fleur59

**ARTURO83** · 07/07/2020, 01h46

Bonjour,

mais il semble que pour chaque feuille la recherche s'arrête à la première occurrence trouvée

Effectivement, j'étais resré sur l'idée de départ qu'il n'y avait pas de doublon.

Voici le fichier modifié
Pièce jointe 574553

le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Sub Recherche()
    Dim Message, Titre, ValeurRecherchee
    Application.ScreenUpdating = False
    Dim Col_Fr As Long, Col_An As Long, Lig_Res As Long
    Dim c As Long, Cpt As Long, i As Long
    Dim Lig_v As Long, Col_v As Long
    Dim v As Object
    'Effacement des précédents résultats
    Sheets("Res").Range("A2:C10000").ClearContents
    Message = "Quelle est la valeur recherchée"
    Titre = "Valeur recherchée"
    ValeurRecherchee = UCase(InputBox(Message, Titre)) 'Demande quelle est la valeur à rechercher
    Col_Fr = 2 'colonne des résultats pour le fichier français
    Col_An = 3 'colonne des résultats pour le fichier anglais
 
    ReDim Valeur(0) As String
    ReDim Trouve(0) As String
    For c = 1 To 2
        If c = 1 Then Classeur = "Français.xlsx" Else Classeur = "Anglais.xlsx"
        Windows(Classeur).Activate 'on active le classeur
        For i = 1 To Sheets.Count 'on passe toutes les feuilles en revue
            With Sheets(i).Range("A1:U42")
                Set v = .Find(ValeurRecherchee, lookat:=xlPart) 'on cherche la valeur
                If Not v Is Nothing Then 'si la valeur est trouvée
                    Pos_Deb = v.Address
                    Do
                        Lig_v = .Cells(v.Row, "A").MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en colonne A
                        Col_v = .Cells(2, v.Column).MergeArea.Cells(1, 1).Value 'on récupère la valeur de la cellule fusionnée en ligne 2
                        Valeur(Cpt) = Sheets(i).Name & Lig_v & Col_v 'on associe le nom de la feuille avec celles de la ligne et de la colonne
                        Trouve(Cpt) = Sheets(i).Cells(v.Row, v.Column) 'on récupère la valeur recherchée
                        Cpt = Cpt + 1 'incrémentation du compteur des valeurs trouvées
                        ReDim Preserve Valeur(Cpt)
                        ReDim Preserve Trouve(Cpt)
                        Set v = .FindNext(v)
                    Loop While Not v Is Nothing And v.Address <> Pos_Deb
                End If
            End With
        Next i
        Windows("Resultats.xlsm").Activate
        If Cpt <> 0 Then
            If c = 1 Then
                Lig_Res = Sheets("Res").Range("A" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "français"
                Sheets("Res").Cells(Lig_Res, Col_Fr).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            Else
                Lig_Res = Sheets("Res").Range("A" & Rows.Count).End(xlUp).Row + 1 'recherche de la première ligne libre colonne "anglais"
                Sheets("Res").Cells(Lig_Res, Col_An).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Valeur) 'restitution des valeurs dans le classeur "Résultats"
            End If
            'Sheets("Res").Cells(Lig_Res, "A") = ValeurRecherchee
            Sheets("Res").Cells(Lig_Res, 1).Resize(Cpt, 1) = Application.WorksheetFunction.Transpose(Trouve) 'restitution des valeurs dans le classeur "Résultats"
            Cpt = 0
        End If
    Next c
    Set v = Nothing
End Sub

Cdlt

**Fleur59** · 08/07/2020, 13h40

Bonjour,
Fond et forme correspondent tout à fait à mon besoin.
Merci à tous deux pour votre aide précieuse. Arturo83 et Menhir.
Vos légendaires connaissances et disponibilités ne m'ont pas fait défaut.
Je clôture le sujet.
@ Bientôt pour d'autres enigmes
Fleur59

recherche d'un terme sous plusieurs onglets (et/ou) plusieurs classeurs et récupération de la colonne et ligne [XL-2013]

Excel

Discussions similaires

Partager

Partager