XL 2019 VBA moteur de recherche

[philgood54000]

Bonjour,

je suis à la recherche d'une aide sur mon fichier VBA moteur de recherche.
En quelques mots , j'ai un fichier assez important contenant des noms composés, j'ai une macro qui me permet d'aller chercher le mot inscrit avec toutes les correspondances liés à ma recherche.
ce que je souhaiterai avoir c'est que ma recherche ne sorte que le mot recherché exactement ( pour exemple : je cherche Martin, il me sort Martint, Martinet, Martins, etc...)

je mets la macro utilisé

Dim tab_mots() As String
Dim compteur As Byte
Dim ligne As Long: Dim ligne_ext As Long
Dim valider As Boolean
Dim ann As String: Dim dat As String
Dim marq As String: Dim pat As String
Dim chaine As String
purger
tab_mots = Split(Range("B2").Value, " ")
ligne = 2: ligne_ext = 6

While Sheets("Base 2021 2022").Cells(ligne, 2).Value <> ""
valider = True

ann = Sheets("TDB").Cells(ligne, 1).Value
dat = Sheets("TDB").Cells(ligne, 2).Value
marq = Sheets("TDB").Cells(ligne, 3).Value
pat = Sheets("TBD").Cells(ligne, 14).Value

chaine = ann & "-" & dat & "-" & marq & "-" & pat

For compteur = 0 To UBound(tab_mots())
If (Len(tab_mots(compteur)) > 3) Then
If (InStr(1, sansAccent(chaine), sansAccent(tab_mots(compteur)), vbTextCompare) = 0) Then
valider = False
Exit For
End If
End If
Next compteur
If (valider = True) Then
Cells(ligne_ext, 1).Value = ann
Cells(ligne_ext, 2).Value = dat
Cells(ligne_ext, 3).Value = marq
Cells(ligne_ext, 7).Value = pat

ligne_ext = ligne_ext + 1

End If
ligne = ligne + 1
Wend
Cells(1, 1).Select
End Sub

Merci d'avance pour votre aide .

 

[philgood54000]

Bonjour,
Ca roule?
Mon code ne convient pas avec plusieurs infos dans la meme cellule. Il faut tester si le nom cherche est contenu dans la cellule

Bonjour philgood54000, Oneida, cp4,

Il faut trouver les mots avec la correspondance exacte :

Sub Rechercher()
Dim cible$, tablo, resu(), i&, s, j%, n&
cible = CStr([B2])
tablo = [Tableau1].Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 1)) 'séparateur espace
    For j = 0 To UBound(s)
        If s(j) = cible Then
            n = n + 1
            resu(n, 1) = tablo(i, 1)
            Exit For
        End If
Next j, i
'---restitution---
With [A6] '1ère cellule de destination
    If n Then .Resize(n) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub

Sub RAZ()
Range("B2,A6:A" & Rows.Count) = ""
End Sub

A+

Bonjour Job75,
super merci beaucoup pour ce fichier, une dernière demande avec cette recherche je voulais savoir si il était possible d'effectuer la recherche sans prendre en compte les accents et majuscules.
encore merci pour ce travail qui va beaucoup m'aider.

 

[job75]

Pour ne traiter que des minuscules utiliser LCase.

Pour ignorer les accents on peut utiliser cette fonction VBA :

Function SansAccent(x$)
Dim a$, b$, i%
a = "àáâãäåòóôõöøèéêëìíîïùúûüÿñç"
b = "aaaaaaooooooeeeeiiiiuuuuync"
For i = 1 To Len(a)
    x = Replace(x, Mid(a, i, 1), Mid(b, i, 1))
Next
SansAccent = x
End Function

 

[philgood54000]

Pour ne traiter que des minuscules utiliser LCase.

Pour ignorer les accents on peut utiliser cette fonction VBA :

Function SansAccent(x$)
Dim a$, b$, i%
a = "àáâãäåòóôõöøèéêëìíîïùúûüÿñç"
b = "aaaaaaooooooeeeeiiiiuuuuync"
For i = 1 To Len(a)
    x = Replace(x, Mid(a, i, 1), Mid(b, i, 1))
Next
SansAccent = x
End Function

Génial merci beaucoup, maintenant si j'utilise un tableau à 15 colonnes et que je souhaite uniquement prendre la colonne 1, 3 , 5 et 7 comment dois je m'y prendre selon le code vba. j'ai essayé de comprendre mais je pense être à des années lumières pour pouvoir l'adapter.
merci

 

[job75]

Il vous suffira de déposer votre fichier ici et quelqu'un vous fera sûrement le travail

 

[philgood54000]

Il vous suffira de déposer votre fichier ici et quelqu'un vous fera sûrement le travail

je peux comprendre votre réponse, mais n'ayant aucune formation il m'est difficile de pouvoir faire un travail comme celui que vous venez de faire, je suis toujours partant pour comprendre.
j'ai fait le même travail version Excel avec des formules pour obtenir les mêmes résultats sur un tableau de milliers lignes, je suis arrivé à saturation et cela prend beaucoup de temps avant d'avoir le résultat.
c'est pour cela que je suis venu ici sollicité de l'aide pour lequel vous avez bien voulu répondre si gentiment.
je mets votre fichier en PJ avec les modifications que je souhaiterai.
merci beaucoup pour tout le temps passé.
bien à vous

 

[job75]

Bonjour philgood54000, le forum,

Sub Rechercher()
Dim cible$, a, tablo, resu(), i&, e, s, j%, n&
cible = SansAccent(LCase(CStr([B2])))
a = Array(1, 3, 7, 9)
tablo = [Tableau1].Resize(, 9) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(tablo), 1 To 4)
For i = 1 To UBound(tablo)
    For Each e In a
        s = Split(tablo(i, e)) 'séparateur espace
        For j = 0 To UBound(s)
            If SansAccent(LCase(s(j))) = cible Then
                n = n + 1
                resu(n, 1) = tablo(i, 1)
                resu(n, 2) = tablo(i, 3)
                resu(n, 3) = tablo(i, 7)
                resu(n, 4) = tablo(i, 9)
                GoTo 1
            End If
    Next j, e
1 Next i
'---restitution---
With [A6] '1ère cellule de destination
    If n Then .Resize(n, 4) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
End Sub

La recherche se fait dans les 4 colonnes A C G I.

A+

 

[philgood54000]

Bonjour philgood54000, le forum,

Sub Rechercher()
Dim cible$, a, tablo, resu(), i&, e, s, j%, n&
cible = SansAccent(LCase(CStr([B2])))
a = Array(1, 3, 7, 9)
tablo = [Tableau1].Resize(, 9) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(tablo), 1 To 4)
For i = 1 To UBound(tablo)
    For Each e In a
        s = Split(tablo(i, e)) 'séparateur espace
        For j = 0 To UBound(s)
            If SansAccent(LCase(s(j))) = cible Then
                n = n + 1
                resu(n, 1) = tablo(i, 1)
                resu(n, 2) = tablo(i, 3)
                resu(n, 3) = tablo(i, 7)
                resu(n, 4) = tablo(i, 9)
                GoTo 1
            End If
    Next j, e
1 Next i
'---restitution---
With [A6] '1ère cellule de destination
    If n Then .Resize(n, 4) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
End Sub

La recherche se fait dans les 4 colonnes A C G I.

A+

Bonjour Job75,

Merci infiniment pour votre travail, sans vous je n'aurais jamais pu avancer.
si je peux contribuer comme vous l'avez je le ferai avec plaisir selon mes compétences bien sur !
Je vous souhaite une très belle journée.