XL 2019 Extraire une chaine entre deux positions

undo74 · 16 Janvier 2021

Bonjour,
Je cherche à extraire une chaîne de caractère entre 2 positions après des tests avec les fonctions cherche et STXT le résultat n'est pas concluant
voir l'exemple en PJ colonne E il serait possible d'avoir une aide soit directement par une fonction Excel ou bien en vba.
PI:
les données dans la pj sont de fausse information.
je vous remercie par avance.

Staple1600 · 16 Janvier 2021

Re

=>undo74
Une solution par formule
(glanée dans mes archives de 2007!)
Adaptée un chouia à ta question
Ici la macro ne sert qu'à insérer les formules
(NB: testé sur ton 1er fichier que je n'ai pas encore effacé mais ce sera fait)

VB:

Sub test_Formules()
[B2:D4].FormulaR1C1 = _
"=IFERROR(TRIM(MID(SUBSTITUTE("" ""&RC1&"" "","" "",REPT("" "",40)),FIND(REPT(""@"",COLUMNS(RC1:RC[-1])),SUBSTITUTE(SUBSTITUTE("" ""&RC1&"" "","" "",REPT("" "",40)),""@"",REPT(""@"",COLUMNS(RC1:RC[-1])),COLUMNS(RC1:RC[-1])))-40,80)),"""")"
End Sub

undo74 · 16 Janvier 2021

soan à dit:
@undo74

as-tu essayé le fichier de mon post #13 ?

ce fichier utilise une fonction personnalisée ; je vais
faire le même fichier, mais avec une sub à la place.

les résultats seront tous identiques, mais ils seront écrits
« en dur » ; tu pourras les modifier plus simplement.

soan

Test post #13
voici le résultat tu n'es pas loin
merci

soan · 16 Janvier 2021

@undo74

comme indiqué précédemment, voici le fichier avec version sub.

Ctrl e ➯ travail effectué (mêmes résultats, écrits « en dur »)

ça sera très rapide, même sur plusieurs milliers de lignes,
car j'ai utilisé la méthode des tableaux.

j'peux pas faire mieux pour le résultat B5 car pour le 1er email
de la cellule A5, il manque un tiret.

tu devras lire attentivement les résultats, et corriger manuellement
ce qui te semble suspect ; mais le plus gros sera déjà fait.

VB:

Sub GetNoms()
  Dim dlg&: dlg = Cells(Rows.Count, 1).End(3).Row: If dlg < 3 Then Exit Sub
  Dim Tbl, txt$, chn$, p1%, p2%, p3%, lig&
  dlg = dlg - 2: Tbl = [A3].Resize(dlg, 2)
  For lig = 1 To dlg
    txt = Tbl(lig, 1)
    p3 = InStrRev(txt, "_"): If p3 = 0 Then Exit Sub
    p2 = InStrRev(txt, "-", p3): If p2 = 0 Then p2 = p3
    p1 = InStrRev(txt, "@", p2)
    chn = Mid$(txt, p1 + 1, p2 - p1 - 1)
    p3 = InStrRev(txt, "_", p1): If p3 = 0 Then GoTo 1
    p2 = InStrRev(txt, "-", p3): If p2 = 0 Then p2 = p3
    p1 = InStrRev(txt, "@", p2)
    chn = Mid$(txt, p1 + 1, p2 - p1 - 1) & "   " & chn
1   Tbl(lig, 2) = chn
  Next lig
  Application.ScreenUpdating = 0
  With [B3].Resize(dlg)
    .ClearContents
    .Value = Application.Index(Tbl, Evaluate("Row(" & "1:" & dlg & ")"), 2)
  End With
End Sub

soan

Staple1600 · 16 Janvier 2021

Re

=>undo74
Et que donne la méga-formule du message #16?

soan · 16 Janvier 2021

@undo74

ajout important : j'ai oublié de préciser que version fonction ou version sub,
pour les deux méthodes, c'est prévu pour 2 emails maxi par cellule ; donc
en colonne A : un seul email ou deux, pas plus ; s'il y a d'autres emails,
ça ne plantera pas, mais ils seront tout simplement ignorés.

ce seront les 2 derniers emails qui seront pris en compte, car les recherches
se font à partir de la fin de la chaîne de caractères.

n'oublie pas de répondre à Staple pour sa méga-formule de son post #16.

soan

undo74 · 16 Janvier 2021

Staple1600 à dit:
Re

=>undo74
Une solution par formule
(glanée dans mes archives de 2007!)
Adaptée un chouia à ta question
Ici la macro ne sert qu'à insérer les formules
(NB: testé sur ton 1er fichier que je n'ai pas encore effacé mais ce sera fait)

VB:

Sub test_Formules() [B2:D4].FormulaR1C1 = _ "=IFERROR(TRIM(MID(SUBSTITUTE("" ""&RC1&"" "","" "",REPT("" "",40)),FIND(REPT(""@"",COLUMNS(RC1:RC[-1])),SUBSTITUTE(SUBSTITUTE("" ""&RC1&"" "","" "",REPT("" "",40)),""@"",REPT(""@"",COLUMNS(RC1:RC[-1])),COLUMNS(RC1:RC[-1])))-40,80)),"""")" End Sub

Hello, oui avec la formule nous avons tous les adresses dans plusieurs colonnes la formule fait le job il faudrait mette dans une colonne les bonnes adresses puis un découpage entre @ et _
ci-dessous le mon résultat souhaité
Merci bcp

Staple1600 · 16 Janvier 2021

Re

Et avec ceci?
(toujours testé sur le fichier initial)
J'obtiens les prénoms et noms

VB:

Sub test_II()
Dim c As Range, t, i%
For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    t = Split(c.Text, "(@")
        For i = LBound(t) To UBound(t)
        If InStr(1, t(i), "-", vbTextCompare) > 0 Then
        c.Offset(, i) = Split(t(i), "-")
        End If
    Next
Erase t
Next
End Sub

undo74 · 16 Janvier 2021

Staple1600 à dit:
Re

Et avec ceci?
(toujours testé sur le fichier initial)
J'obtiens les prénoms et noms

VB:

Sub test_II() Dim c As Range, t, i% For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp)) t = Split(c.Text, "(@") For i = LBound(t) To UBound(t) If InStr(1, t(i), "-", vbTextCompare) > 0 Then c.Offset(, i) = Split(t(i), "-") End If Next Erase t Next End Sub

Hello, super tu as trouvé la bonne solution il reste la compilation des adresses dans colonne.
merci bcp

Staple1600 · 16 Janvier 2021

Re

Pour la suite, je passe le relais
Car là il est l'heure du dodo
Je repasserai demain

NB: Qu'est-ce que tu entends par ?

il reste la compilation des adresses dans colonne.

soan · 17 Janvier 2021

Bonjour @undo74, Staple,

j'ai trouvé une meilleure méthode !

c'est toujours une sub ; toujours avec la méthode super rapide
des tableaux ; même utilisation : Ctrl e ➯ travail effectué :

bonus supplémentaire : ça marche pareil quel que soit
le nombre d'adresses email : une, deux, ou plus !

autre bonus : ça marchera aussi s'il y a des prénoms
composés tels que jean-pierre ou jean-paul.

c'est le mari de Samantha et Endora qui vont être contents !

code VBA complet :

VB:

Sub GetNoms()
  Dim dlg&: dlg = Cells(Rows.Count, 1).End(3).Row: If dlg < 3 Then Exit Sub
  Dim Tbl, txt$, lng%, s1$, s2$, p1%, p2%, lig&
  dlg = dlg - 2: Tbl = [A3].Resize(dlg, 2)
  For lig = 1 To dlg
    txt = Tbl(lig, 1): lng = Len(txt): If lng = 0 Then GoTo 1
    s2 = "": p1 = 1
    Do
      p1 = InStr(p1, txt, "(@"): If p1 = 0 Then Exit Do
      p2 = InStr(p1 + 2, txt, ")"): If p2 = 0 Then Exit Do
      s1 = Mid$(txt, p1 + 2, p2 - p1 - 2)
      p1 = InStrRev(s1, "-"): If p1 > 0 Then s1 = Left$(s1, p1 - 1)
      s2 = s2 & s1 & ", ": p1 = p2 + 1
    Loop
    If s2 <> "" Then Tbl(lig, 2) = Left$(s2, Len(s2) - 2)
1 Next lig
  Application.ScreenUpdating = 0
  With [B3].Resize(dlg)
    .ClearContents
    .Value = Application.Index(Tbl, Evaluate("Row(" & "1:" & dlg & ")"), 2)
  End With
End Sub

soan

mapomme · 17 Janvier 2021

Bonsoir à tous,

Une formule qui fonctionne pour les trois cas du message 1:

VB:

=SUPPRESPACE(DROITE(SUBSTITUE(GAUCHE(A3;CHERCHE("-";A3)-1);"@";REPT(" ";255));255))

soan · 17 Janvier 2021

Bonjour @mapomme, le fil,

j'ai téléchargé ton fichier.

en G4 : "tata.fontaine" : ok, car y'a qu'un seul email en A4.

en G3 : "toto.durant" ➯ il manque "titi.bertand"

en G5 : "titi.all" ➯ il manque "fr-team"

en reprenant tes données, j'obtiens ces résultats
avec le code VBA du fichier de mon post #25 :

soan

mapomme · 17 Janvier 2021

Bonjour @soan,

soan à dit:
en G3 : "toto.durant" ➯ il manque "titi.bertand"

J'ai répondu à la première question. L'attitude de plus en plus fréquente des questionneurs qui consiste à jeter en pâture une question sans réflexion, sans explications réfléchies, sans fichier ou pire un fichier faux ou simpliste sans oublier le fait de ne joindre qu'une image et en changeant de but une ou plusieurs fois pendant la discussion commence à me les brouter menu menu. Donc je réponds à la question initiale, un point c'est tout.

soan · 17 Janvier 2021

@mapomme, @Staple1600, le fil,

moi aussi, j'ai vu des posts où le fichier joint par le demandeur n'était pas le bon, car il s'était
trompé de fichier ; ainsi que des énoncés mal faits ou bâclés ; peut-être faudrait-il ajouter dans
la charte : « l'entraide est gratuite, mais prenez quand même le temps d'écrire un énoncé clair,
avec tous les éléments nécessaires à la résolution de votre problème ; relisez-vous, et si vous
joignez un fichier, vérifiez que c'est le bon fichier et pas un autre, ni une ancienne version. »

soan

Staple1600 · 17 Janvier 2021

Bonjour le fil, (matinal mapomme )

=>under74
Je viens de voir que tu utilisais Excel 2019.
Donc profitons de la puissance de PowerQuery.
C'est plus intuitif, ergonomique.
Cela se pilote à la souris.
Et surtout actualisable automatiquement si le fichier source change.
Pas de formules, pas de VBA (donc pas de risque de bug)
Voir ce que cela donne ci-dessous

NB: Dans l'encadré, c'est du langage M (visible dans l'Editeur avancé)
Cela recapitule les différentes actions que j'ai réalisé à la souris dans PowerQuery.

XL 2019 Extraire une chaine entre deux positions

undo74

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

undo74

XLDnaute Nouveau

soan

XLDnaute Barbatruc

Pièces jointes

Staple1600

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

undo74

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

undo74

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Discussions similaires