XL 2010 Vérifier Nom Prénom (comparaison lettre accentuée)

laurent950 à dit:

Re après modification

C'est maintenant ultra rapide, il n'y a plus de Récurcivité

VB:

''''verif client existe
Sub Test_Fonction()    'à exploiter
    Dim sNomClt As Boolean
    sNomClt = VerifClients(Range("B3"))
    If sNomClt = True Then
        MsgBox "Le client existe déjà"
    Else
        MsgBox "Le client n'existe pas"
        'créer client
        '[ °°°° Votre Code  °°°° ]
        '     ***************
        '[ °°°° Votre Code  °°°° ]
    End If
End Sub

VB:

Private Function VerifClients(ByRef TestFormatTexte As String) As Boolean
    Dim tb As Variant
    Dim i, j As Variant
    Dim TempText As String
    tb = Range("Tableau1[#All]")
    Dim RX As Object, itm As Object
    Set RX = CreateObject("VBScript.RegExp")
    Const sAccents As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const sNoAccents As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
  
    ' Teste et Transforme le Format du texte envoyer (Sans accents et sans espaces)
       RX.Global = True
       RX.Pattern = "(.)"
       RX.Pattern = Mid(RX.Replace(sAccents, "|$1"), 2)
       For Each itm In RX.Execute(TestFormatTexte)
            TestFormatTexte = Trim(UCase(Replace(TestFormatTexte, itm, Mid(sNoAccents, InStr(1, sAccents, itm, 0), 1))))
       Next itm
            TestFormatTexte = Trim(UCase(TestFormatTexte))
    ' Test Si existe ou n'existe pas
        Dim Flag As Boolean
  
    For i = LBound(tb, 2) To 1
        For j = 2 To UBound(tb, 1)
            RX.Global = True
            RX.Pattern = "(.)"
            RX.Pattern = Mid(RX.Replace(sAccents, "|$1"), 2)
                For Each itm In RX.Execute(tb(j, i))
                    tb(j, i) = Replace(tb(j, i), itm, Mid(sNoAccents, InStr(1, sAccents, itm, 0), 1))
                Next itm
            tb(j, i) = Trim(UCase(tb(j, i)))
            'Le Test (si existe Flag = True)
            If TestFormatTexte = tb(j, 1) Then Flag = True: Exit For
        Next j
        If Flag = True Then Exit For
    Next i
' Renvois le test
VerifClients = Flag
End Function

Cliquez pour agrandir...