XL 2019 Extraire une chaine entre deux positions

[undo74]

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]

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)

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]

@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]

@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. 🙂

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]

Re

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

 

[soan]

@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]

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)

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]

Re

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

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]

Re

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

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]

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]

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 :

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]

Bonsoir à tous,

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

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

 

[soan]

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]

Bonjour @soan,

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]

@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]

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.