XL 2019 Extraire une chaine entre deux positions

undo74

XLDnaute Nouveau
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.
 

Pièces jointes

  • Extraire Chaine.xlsx
    9.4 KB · Affichages: 34
Dernière édition:

Staple1600

XLDnaute Barbatruc
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

XLDnaute Nouveau
@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
1610831363997.png
 

soan

XLDnaute Barbatruc
Inactif
@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
 

Pièces jointes

  • Extraire Chaine.xlsm
    16.6 KB · Affichages: 8
Dernière édition:

soan

XLDnaute Barbatruc
Inactif
@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
 
Dernière édition:

undo74

XLDnaute Nouveau
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
1610833919635.png
 

Staple1600

XLDnaute Barbatruc
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

XLDnaute Nouveau
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
 

soan

XLDnaute Barbatruc
Inactif
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é :


Image.jpg


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
 

Pièces jointes

  • Extraire Chaine.xlsm
    17.1 KB · Affichages: 6
Dernière édition:

soan

XLDnaute Barbatruc
Inactif
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 :


Image.jpg


soan
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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

XLDnaute Barbatruc
Inactif
@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

XLDnaute Barbatruc
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
01_POWERQUERY.jpg
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.
 

Discussions similaires

Statistiques des forums

Discussions
311 723
Messages
2 081 932
Membres
101 844
dernier inscrit
pktla