XL 2016 Récupérer dans un libellé un mot avant une cassure

[Armand11]

Bonjour la communauté Exceldownload,

Tout d'abord meilleurs voeux pour cette nouvelle année.
J'ai besoin de votre aide pour récupérer en automatique un mot d'un libellé :

Voici mon libellé :
"Total Bill Variance//PO 1-23-001993//SUPP59 Thorlabs//AP4M3M"

Et je dois récupérer SUPP59 c'est à dire tous les SUPP et ce qu'il y a aprés jusquà la cassure c'est à dire l'espace avant "Thorlab".

J'ai essayé de combiner les formules STXT(A8;36;8) et ensuite un Gauche(A9;6) mais dans certain cas ca ne marche pas. Car en fait mes Codes Fournisseurs peuvent être : SUPP30 ou SUPP1 ou SUPP1984 (ils ne dépassent pas 8 caractères)

Merci beaucoup pour votre aide
Armand

 

[job75]

Bonjour le forum,

Ho le joli GoTo 😀

Oui bien sûr on peut le remplacer par Exit For (comme pour le 2ème test) mais c'est peut-être moins clair :

Function Extrait$(txt$, crit1$, crit2$)
Dim L1%, L2%, L, i%, j%, a(), n%
L1 = Len(crit1)
L2 = Len(crit2)
L = Len(txt)
For i = 1 To L
    If Mid(txt, i, L1) = crit1 Then
        For j = i + L1 To L
            If Mid(txt, j, L1) = crit1 Then i = j - 1: Exit For
            If Mid(txt, j, L2) = crit2 Then
                ReDim Preserve a(n)
                a(n) = Mid(txt, i, j + L2 - i) 'avec le 2ème critère (espace)
                n = n + 1
                i = j
                Exit For
            End If
        Next j
    End If
Next i
If n Then Extrait = Join(a, "") 'concaténation sans séparateur
End Function

A+

 

[Nain porte quoi]

Hello,

pour le fun, juste pour éviter le GoTo 😱 ou la sortie (brutale 😀) de la boucle

Function Extrait$(txt$, crit1$, crit2$)
    Dim L1%, L2%, L, i%, j%, a(), n%
    Dim Trouve As Boolean
    L1 = Len(crit1)
    L2 = Len(crit2)
    L = Len(txt)
    i = 1
    While i <= L
        If Mid(txt, i, L1) = crit1 Then
            j = i + L1
            Trouve = False
            While j <= L And Not Trouve
                If Mid(txt, j, L1) = crit1 Then
                    i = j - 1
                    Trouve = True
                ElseIf Mid(txt, j, L2) = crit2 Then
                    ReDim Preserve a(n)
                    a(n) = Mid(txt, i, j + L2 - i) 'avec le 2ème critère (espace)
                    n = n + 1
                    i = j + L2 - 1
                    Trouve = True
                Else
                    j = j + 1
                End If
            Wend
        End If
        i = i + 1
    Wend
    If n > 0 Then Extrait = Join(a, "") 'concaténation sans séparateur
End Function

 

[job75]

Pour le fun aussi, chez moi par rapport à la durée d'exécution de la fonction du post #12 :

- celle du post #16 est la même

- celle du post #17 prend 5% de plus.

La différence est faible mais nette.

Edit : il serait intéressant de comparer avec les expressions régulières mais je ne sais pas les utiliser pour qu'elles fassent exactement la même chose que ma fonction.

 

[job75]

Bonjour le forum,

Voici une solution avec Split :

Function Extrait$(txt$, crit1$, crit2$)
Dim s, e, p%
s = Split(txt, crit2)
For Each e In s
    p = InStrRev(e, crit1) 'repère la dernière occurrence
    If p Then
        e = Mid(e, p)
        Extrait = Extrait & e & crit2 'concaténation
    End If
Next
End Function

La durée du calcul est 20% inférieure à celle du post #12.

A+

 

[Nain porte quoi]

Hello le forum, @job75

puisqu'on en est à comparer les durées avec différentes fonctionnalités, voici une version avec RegExp.
Je n'ai pas suffisamment de données pour comparer, @job75 tu veux bien faire le test steuplé ?

Function ExtraitRegEx$(txt$, crit1$, crit2$)
    
    Dim Reg_EX As Object
    Dim Liste_Correspondances As Object
    Dim Correspondance As Object
    
    Set Reg_EX = CreateObject("VBScript.RegExp")
    
    With Reg_EX
        .Global = True
        .IgnoreCase = False ' respecte la casse
        .Pattern = crit1 & "(?:(?!" & crit1 & ").)*?" & crit2
    End With
    
    Set Liste_Correspondances = Reg_EX.Execute(txt)
    
    For Each Correspondance In Liste_Correspondances
        ExtraitRegEx = ExtraitRegEx & Correspondance.Value
    Next Correspondance
    
End Function

 

[job75]

Pour tester la fonction du post #19 j'ai recopié les 4 lignes du fichier sur 70 000 lignes : le recalcul des formules s'effectue en 0,8 seconde.

J'ai fait la même chose avec la fonction du post #20 : j'ai quitté Excel au bout de 15 minutes.

 

[nullosse]

Salut,
attention c'est toujours plus lent de passer par du VBA pour des fonctions personnalisées et en plus pour des regex on utilise un objet COM.
Voici une formule excel365 à peu près équivalente à celle de Job75 avec textjoin et regexextract ( en anglais car je n'ai pas excel365 et je fais des essais avec le excel365 gratuit en ligne qui est en anglais).

=TEXTJOIN(" ", TRUE, REGEXEXTRACT(A5, "SUPP[^ ]*",1))

La ligne 4 donne un résultat différent de la fonction de Job75 mais n'importe comment sa fonction ne correspondait plus à la demande initiale et que se passe-t-il quand le SUPPxx est à la fin du texte sans espace.
Nullosse

 

[job75]

Bonjour nullosse,

Je vois qu'en B4 vous obtenez "SUPP59SUPP85" alors qu'il faut obtenir "SUPP85 ".

A+

 

[patricktoulon]

bonsoir
avec un jump instr

Function Extrait2$(txt$, crit1$, crit2$)
    Dim s, e, p%, L&, Fin&
    L = Len(crit1)
    e = 1
    Do While e > 0
        e = InStr(e, txt, crit1) 'PASSE AU SUIVANT
        If e = 0 Then Exit Function
        Fin& = InStr(e + L, txt, crit2) - e + 1 '+1 pour garder l'espace
        If Fin <= 0 Then Exit Function
        Extrait2 = Extrait2 & Mid(txt, e, Fin)
        e = e + Fin
        If Fin < L Then Exit Function
    Loop
End Function

désolé @job75
sur 4000 lignes testées chez moi bien plus d'une seconde je dirais même au moins 2
dans ma version
la boucle tourne autant de fois que d'occurences c'est tout
on sort si instr crit1 donne 0
on sort si instr crit2 donne 0 ous moins
on sort si len( txt) -derniere position instr crit2 est plus petit que crit1
quasi instantané

 

[nullosse]

Attention ce n'est pas le vrai temps de calcul car on mesure :

• le temps d’un recalcul isolé
• dans un environnement sans dépendances
• sans recalcul de graphe
• sans propagation
• sans multithreading
• sans volatilité
• sans cache
• sans optimisation du moteur

Cela permet de comparer les performances des formules les unes par rapport aux autres.

 

[nullosse]

Salut,

et voici les résultats plus réalistes pour 50000 lignes.
Le principe :
on efface complétement la feuille .
1 - On remplit la feuille avec le texte et les formules par VBA avec tous les événements , l'affichage etc désactivés .
2 - On fait un calcul par colonne de formules et entre chaque test on modifie la totalité des cellules en A (un replace avec une meme valeur suffit)
voici les résultats :

Analyse des résultats​

Méthode	Temps	Interprétation
STXT/TROUVE	78 ms	Très rapide. Normal : fonctions Excel natives, pas de regex, pas de VBA.
REGEXEXTRACT	172 ms	Plus lent. Normal : les regex Excel sont coûteuses, surtout sur 50 000 lignes.
UDF (ExtraitSplit)	398 ms	Cohérent. Une UDF VBA, même optimisée, reste plus lente que les fonctions natives.
UDF (Extrait)	836 ms	Très cohérent. Les UDF non optimisées sont souvent 2× à 10× plus lentes.

Moralité : la solution d'Hecatonchire est plus rapide que les autres solutions.
Nullosse

 

[patricktoulon]

re
tu a essayé l'extrait2?

 

[nullosse]

re
tu a essayé l'extrait2?

Salut PatrickToulon:
extrait2 : 441 ms avec le texte du post original

 

[patricktoulon]

tu fait comment les tests?

 

[nullosse]

tu fait comment les tests?

j'ai expliqué dans le post #26 et je fais un calculate sur une plage qui correspond à une colonne de formule : il faut surtout réécrire toutes les cellules qui servent dans la formule avant de lancer le calculate (c'est à dire ici les cellules de la colonne A) et bloquer le calcul avant le calculate