VBA : Extraire une chaine de caratères à parir d'une base de noms

[Grm]

Bonjour !

Je cherche à extraire une chaine de caractères (un nom de fleur dans l'exemple) d'une cellule en récupèrant ce nom d'une liste.

J'ai trouvé une solution grâce à une formule mais cette dernière devient vite très longue si la liste de nom grandie. De plus j'aimerais une solution sous forme de macro qui me permetterait d'actualiser l'extraction de la chaine de caractère après des ajouts de noms dans la base.

Fichier avec solution (formule) en PJ

Merci pour votre aide.

 

[Dranreb]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour
Par fonction personnalisée:

Function Contient(Liste As Range, Chaîne As String) As String
Dim Vlst() As Variant, N As Long
Vlst = Liste.Value
For N = 1 To UBound(Vlst)
   If InStr(Chaîne, Vlst(N, 1)) > 0 Then Exit For
   Next N
If N <= UBound(Vlst) Then Contient = Vlst(N, 1)
End Function

=Contient($E$2:$E$5;$A2)

À+

 

[job75]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour Grm, salut Dranreb,

Juste un peu différent :

Function FLEUR(txt As String) As String
Dim b, t
b = [Base] 'pour avoir une matrice (plus rapide)
For Each t In b
  If InStr(txt, t) Then FLEUR = t: Exit Function
Next
End Function

Fichier joint.

A+

 

[Pierrot93]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour grm, Bernard, Job

une autre approche :

Option Explicit
Sub test()
Dim x As Range, c As Range, p As String
With Sheets("Feuil1")
For Each x In .Range("E2", .Range("E65536").End(xlUp))
    With .Range("A2", .Range("A65536").End(xlUp))
        Set c = .Find(x.Value, , xlValues, xlPart, , , False)
        If Not c Is Nothing Then
            p = c.Address
            Do
                c.Offset(0, 1).Value = x.Value
                Set c = .FindNext(c)
            Loop While c.Address <> p
        End If
    End With
Next x
End With
End Sub

bon après midi
@+

Edition : manquait 2 points (bloc with)

 

[job75]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Re, salut encore Pierrot

Bien voir que la fonction du post #3, contrairement à celle de Dranreb, souffre d'un handicap.

Si l'on modifie la base des fleurs (colonne E), la colonne B ne se met pas à jour car la fonction ne se recalcule pas.

Pour forcer le recalcul de la fonction, 2 solutions :

1) rendre la fonction volatile :

Function FLEUR(txt As String) As String
Dim b, t
Application.Volatile
b = [Base] 'pour avoir une matrice (plus rapide)
For Each t In b
  If InStr(txt, t) Then FLEUR = t: Exit Function
Next
End Function

2) introduire la base comme argument (comme l'a fait Dranreb) :

Function FLEUR(txt As String, base) As String
Dim t
base = base 'pour avoir une matrice (plus rapide)
For Each t In base
  If InStr(txt, t) Then FLEUR = t: Exit Function
Next
End Function

Voir fichier (2).

A+

 

[Grm]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Merci à tous !!!! Ces solutions me conviennent parfaitement.

Bonne après midi !

 

[job75]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Re,

S'il peut y avoir plusieurs noms de fleurs dans une cellule, voir ce fichier (3).

A+

 

[Grm]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Merci pour ces solutions qui m'aident beaucoup.

J'ai une petite MAJ à faire en distinguant une base de recherche, de la base de résultat. En effet il peut y avoir des dsignations codées ou avec des fautes de frappe.

Je suis un grand débutant en VBA et je vous remercie pour votre aide.

 

[Pierrot93]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour,

essaye en modifiant comme suit :

Option Explicit
Sub test()
Dim x As Range, c As Range, p As String
With Sheets("Feuil1")
For Each x In .Range("D2", .Range("D65536").End(xlUp))
    With .Range("A2", .Range("A65536").End(xlUp))
        Set c = .Find(x.Value, , xlValues, xlPart, , , False)
        If Not c Is Nothing Then
            p = c.Address
            Do
                c.Offset(0, 1).Value = x.Offset(0, 1).Value
                Set c = .FindNext(c)
            Loop While c.Address <> p
        End If
    End With
Next x
End With

bonne journée
@+

 

[job75]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour le fil, le forum,

Grm m'a demandé par MP de donner une solution au dernier problème, par fonction VBA.

Alors voici 2 solutions.

1) Avec base de recherche intermédaire :

Function FLEUR(txt As String, base) As String
Dim i%
base = base 'pour avoir une matrice (plus rapide)
For i = 1 To UBound(base)
  If InStr(txt, base(i, 1)) And InStr(FLEUR, base(i, 2)) = 0 Then _
    FLEUR = FLEUR & IIf(FLEUR = "", "", ", ") & base(i, 2)
Next
End Function

2) Sans base intermédiaire :

Function FLEUR(txt As String, base) As String
Dim i%, t, s
base = base 'pour avoir une matrice (plus rapide)
txt = Application.Trim(txt) 'fonction SUPPRESPACE
For i = 1 To Len(txt) 'insère le caractère générique *
  t = t & "*" & Mid(txt, i, 1)
Next
txt = t & "*"
s = Split(txt) 'sépare chaque mot
For i = 0 To UBound(s)
  For Each t In base
    If t Like s(i) And Not FLEUR Like "*" & t & "*" Then _
      FLEUR = FLEUR & IIf(FLEUR = "", "", ", ") & t
  Next
Next
End Function

EDIT : attention pour ceux qui ouvriraient le fichier du post #8 de Grm.

Le calcul est en mode manuel, ça met un peu le pataquès

A+

 

[job75]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Bonjour le fil, le forum,

Une variante pour la recherche avec base intermédiaire.

Chaque résultat correspond à un mot bordé par des espaces :

Function FLEUR(txt As String, base) As String
Dim i%
base = base 'pour avoir une matrice (plus rapide)
txt = " " & txt & " "
For i = 1 To UBound(base)
  If InStr(txt, " " & base(i, 1) & " ") And InStr(FLEUR, base(i, 2)) = 0 Then _
    FLEUR = FLEUR & IIf(FLEUR = "", "", ", ") & base(i, 2)
Next
End Function

Voir cellule A14.

A+

 

[Grm]

Re : VBA : Extraire une chaine de caratères à parir d'une base de noms

Toutes ces solutions sont parfaites, merci beaucoup à Job75, Pierrot93 et Dranreb pour votre aide !!