Discussion :

[Henri1830]

Bonjour le Forum,

Voici la problématique que je souhaite vous soumettre.
J'ai besoin de faire une recherche par n'importe quelle partie du nom dans une liste de 250 pays et d'afficher tous les résultats où l'on retrouve mon argument de recherche.
J'utilise un code qui fonctionne très bien mais...
Si je recherche "amer", il va retrouver "Cameroun" mais pas "Amérique"

Vous l'avez compris, le problème sont les caractères accentués. Est-ce que l'un parmi vous aurait une fonction qui permettrait de retrouver les 2 mots que l'argument de recherche soit "amer" ou "amér" ?

Merci d'avance.

Henri

[mat955]

Bonjour,

Il n'existe pas à ma connaissance de fonction "simple" permettant de faire cela.
Il faudrait passer soit par une imbrication de SUBSTITUE ou alors créer une fonction personnalisée en VBA.
Que ce soit l'une ou l'autre des manières, il y a plein d'exemples sur internet, tu n'as pas beaucoup cherché

[Henri1830]

Si si, j'ai effectivement trouvé des choses, mais je tentais ma chance ici, quelque fois qu'une solution native VBA existerait.
Merci quand même.

[patricktoulon]

bonjour

Si si, j'ai effectivement trouvé des choses, mais je tentais ma chance ici, quelque fois qu'une solution native VBA existerait.
Merci quand même.

je pense que ca intéresse plusieurs d'entre nous tu peux partager c'est pas interdit

[Henri1830]

Bien volontiers !

Voici le code de la fonction:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 
Function SupprimerAccents(ByVal sChaine As String) As String
Dim sTmp As String, i As Long, p As Long
Const sCarAccent As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
Const sCarSansAccent As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
    sTmp = sChaine
    For i = 1 To Len(sTmp)
        p = InStr(sCarAccent, Mid(sTmp, i, 1))
        If p > 0 Then Mid$(sTmp, i, 1) = Mid$(sCarSansAccent, p, 1)
    Next i
    SupprimerAccents = sTmp
End Function

On peut donc l'utiliser de cette manière:

Code :

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

1
2
3
4
Sub test()
    Range("A1").Value = "élève" ' Contenu de la cellule A1 : élève
    Range("A2").Value = SupprimerAccents(Range("A1")) ' Contenu de la cellule A2 : eleve
End Sub

Merci à Kiki29 qui a présenté cette fonction à cette page :
https://www.developpez.net/forums/d1...es-caracteres/

Enjoy !

[marot_r]

Bonjour.

On peut aussi le faire ainsi :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Function SupprimerAccents(ByVal sChaine As String) As String
    dim sTmp
    Const sCarAccent As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
    Const sCarSansAccent As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
    sTmp = sChaine
 
    For i = 1 To Len(sCarAccent)
        sTmp=replace(stmp, mid(sCarAccent, i, 1), mid(sCarSansAccent, i, 1))
    Next i
 
    SupprimerAccents = sTmp
End Function

A+

[anasecu]

Bonjour le Forum,

Est-ce que l'un parmi vous aurait une fonction qui permettrait de retrouver les 2 mots que l'argument de recherche soit "amer" ou "amér" ?

Cette discussion est marquée résolue mais je n'ai pas vu de résolution alors je vous propose la mienne qui s'applique aux communes françaises.

La recherche permet de saisir sans accents et de rechercher toutes les variantes et si l'on saisi une lettre accentuée seule celle-ci est prise en compte.
Elle se fait à l'aide d'un filtre élaboré paramétré par ce 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
Option Explicit
Dim idc As Long     ' index caractère
Dim pda As Integer  ' position de l'accent
Dim pdc As Integer  ' position du caractère
Dim acc As String   ' accents
Dim cac As String   ' caractères à accentuer
Dim chs As String   ' chaine sélections
Dim chx As String   ' choix sélection
Dim tbc As String   ' table recherche
Dim tba             ' table accents
 
Private Sub Worksheet_Change(ByVal sel As Range)
If Not Intersect(sel, [Choix]) Is Nothing Then
    If Len([Choix].Value) > 2 Then
        tba = Application.Transpose([accents].Cells.Value): cac = ""
        For idc = 1 To UBound(tba): cac = cac & Left(tba(idc), 1): Next idc
        acc = "_" & Join(tba, "_") & "_"
        chx = "*" & [Choix].Value & "*": tbc = chx: chs = ""
        Call ins_acc
        Cells([resu].Row + 1, [resu].Column).Resize(Cells(Rows.Count, [resu].Column).End(xlUp).Row, 3).ClearContents
        With Cells([Choisir].Row + 1, [Choisir].Column)
            .Resize([Choisir].Count, 1).ClearContents: tba = Split(tbc, "|")
            .Resize(UBound(tba), 1) = Application.Transpose(tba)
        End With
        [Base].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[Choisir], CopyToRange:=[resu], Unique:=False
        [E7].Activate: sel.Activate
    End If
End If
End Sub
 
Public Sub ins_acc()
Dim idx As Long
Dim chc As String
    For idc = 1 To Len(chx)
        pdc = InStr(cac, Mid(chx, idc, 1)): If pdc > 0 Then Exit For
    Next idc
    If idc <= Len(chx) Then
        pda = InStr(acc, "_" & Mid(chx, idc, 1))
        For idx = pda + 2 To Len(acc)
            chc = Replace(chx, Mid(cac, pdc, 1), Mid(acc, idx, 1))
            tbc = tbc & "|" & chc: chs = chs & chc & "|"
            If Mid(acc, idx + 1, 1) = "_" Then Exit For
        Next idx
        idx = InStr(chs, "|"): chx = Left(chs, idx - 1): chs = Mid(chs, idx + 1): Call ins_acc
    End If
End Sub

Je joint le classeur pour un test plus facile.