XL 2013 Extraire des données d'une cellule

elodieee · 13 Août 2019

Bonjour,
Je cherche en vain une solution à mon problème sur excel.
Dans le cadre de mon travail, je reçois des extractions Outlook sur Excel.
Le corps du message en entier tiens dans une seule cellule. J'ai donc un texte immense dans chaque cellule.
Le travail consiste à extraire des mots clés de chaque mail.

Par exemple:
A1 B1 C3
email adresse 13/08/2019 Corps du message

Les messages ont toujours le même style de texte:

Message reçu ce jour
SENDER: BANQUE TRUC
DEVISES : EURO
MONTANT : 55
Dossier clos

Le but serait d'extraire uniquement les données SENDER, DEVISES et MONTANT dans une autre feuille afin de pouvoir établir un total pour chaque banque.

Je vous mets un exemple ce sera plus parlant !

Je vous remercie pour votre aide!

Bonne journée

mapomme · 13 Août 2019

Bonjour @elodieee, bienvenue sur XLD ,

Un essai par VBA. Cliquez sur le bouton HOP!
Le code est dans module1:

VB:

Sub test()
Dim t, s, i&, j&, n&

With Sheets("Feuil1")
  t = Range("c:c").Resize(Cells(Rows.Count, "c").End(xlUp).Row)
  ReDim v(1 To 3, 1 To 1)
  n = 1: v(1, n) = "SENDER": v(2, n) = "DEVISE": v(3, n) = "MONTANT"
  For i = 1 To UBound(t)
    s = Split(t(i, 1), Chr(10))
    If IsArray(s) Then
      For j = LBound(s) To UBound(s)
        If s(j) Like "SENDER : *" Then
          n = n + 1
          ReDim Preserve v(1 To 3, 1 To n)
          v(1, n) = Mid(s(j), Len("SENDER : "), 999)
          v(2, n) = Mid(s(j + 2), Len("DEVISE : "), 999)
          v(3, n) = CDbl(Replace(Mid(s(j + 1), Len("MONTANT : "), 999), ".", ","))
        End If
      Next j
    End If
  Next i
End With
With Sheets("RES")
  .Columns("a:c").Clear
  .Range("a1").Resize(UBound(v, 2), 3) = Application.Transpose(v)
  .Range("c1").Resize(UBound(v, 2)).NumberFormat = "0.00"
  .Select
End With
End Sub

edit : Bonsoir @zebanx , @djidji59430

djidji59430 · 13 Août 2019

Bonjour à tous,

un autre par formule :

pierrejean · 13 Août 2019

Bonsoir à tous

Je l'ai commis alors je le livre
et je regarde le boulot des copains !!!

mapomme · 13 Août 2019

Bonsoir @pierrejean ,

zebanx · 13 Août 2019

Bonsoir Mapomme, PierreJean, Djidji59340 -->

@mapomme.
Joli code une fois de plus. Comme PierreJean, deux approches c'est top!

Peux-tu m'expliquer cependant pourquoi tu utilises STP une boucle
If IsArray(s) then.... end if
?

@+ et merci pour ta réponse.

mapomme · 13 Août 2019

Re @zebanx ,

zebanx à dit:
Peux-tu m'expliquer cependant pourquoi tu utilises STP une boucle
If IsArray(s) then.... end if

Tu veux sans doute parler de condition au lieu de boucle ?
Imaginons que la cellule ne contienne aucun caractère Chr(10) (c'est le cas pour la ligne 1 et pour la ligne 2).
Dans ce cas, s = Split(t(i, 1), Chr(10)) ne renverrait pas un tableau mais une variable simple contenant tout le contenu de la cellule.
s n'étant pas dans ce cas un tableau, l'instruction For j = LBound(s) To UBound(s) provoquerait une erreur puisque LBound(s) n'existerait pas tout comme Ubound(s) n'existerait pas non plus.
Pour me prémunir contre cette erreur, je n'exécute la boucle que si s est vraiment un tableau d'où la condition...

zebanx · 13 Août 2019

Super Mapomme.

Merci, c'est très clair as usual.

Bonne nuit

elodieee · 14 Août 2019

mapomme à dit:

Bonjour @elodieee, bienvenue sur XLD ,

Un essai par VBA. Cliquez sur le bouton HOP!
Le code est dans module1:

VB:

Sub test()
Dim t, s, i&, j&, n&

With Sheets("Feuil1")
  t = Range("c:c").Resize(Cells(Rows.Count, "c").End(xlUp).Row)
  ReDim v(1 To 3, 1 To 1)
  n = 1: v(1, n) = "SENDER": v(2, n) = "DEVISE": v(3, n) = "MONTANT"
  For i = 1 To UBound(t)
    s = Split(t(i, 1), Chr(10))
    If IsArray(s) Then
      For j = LBound(s) To UBound(s)
        If s(j) Like "SENDER : *" Then
          n = n + 1
          ReDim Preserve v(1 To 3, 1 To n)
          v(1, n) = Mid(s(j), Len("SENDER : "), 999)
          v(2, n) = Mid(s(j + 2), Len("DEVISE : "), 999)
          v(3, n) = CDbl(Replace(Mid(s(j + 1), Len("MONTANT : "), 999), ".", ","))
        End If
      Next j
    End If
  Next i
End With
With Sheets("RES")
  .Columns("a:c").Clear
  .Range("a1").Resize(UBound(v, 2), 3) = Application.Transpose(v)
  .Range("c1").Resize(UBound(v, 2)).NumberFormat = "0.00"
  .Select
End With
End Sub

edit : Bonsoir @zebanx , @djidji59430

Super merci beaucoup!!!!!!!
C'est parfait

elodieee · 14 Août 2019

mapomme à dit:

Bonjour @elodieee, bienvenue sur XLD ,

Un essai par VBA. Cliquez sur le bouton HOP!
Le code est dans module1:

VB:

Sub test()
Dim t, s, i&, j&, n&

With Sheets("Feuil1")
  t = Range("c:c").Resize(Cells(Rows.Count, "c").End(xlUp).Row)
  ReDim v(1 To 3, 1 To 1)
  n = 1: v(1, n) = "SENDER": v(2, n) = "DEVISE": v(3, n) = "MONTANT"
  For i = 1 To UBound(t)
    s = Split(t(i, 1), Chr(10))
    If IsArray(s) Then
      For j = LBound(s) To UBound(s)
        If s(j) Like "SENDER : *" Then
          n = n + 1
          ReDim Preserve v(1 To 3, 1 To n)
          v(1, n) = Mid(s(j), Len("SENDER : "), 999)
          v(2, n) = Mid(s(j + 2), Len("DEVISE : "), 999)
          v(3, n) = CDbl(Replace(Mid(s(j + 1), Len("MONTANT : "), 999), ".", ","))
        End If
      Next j
    End If
  Next i
End With
With Sheets("RES")
  .Columns("a:c").Clear
  .Range("a1").Resize(UBound(v, 2), 3) = Application.Transpose(v)
  .Range("c1").Resize(UBound(v, 2)).NumberFormat = "0.00"
  .Select
End With
End Sub

edit : Bonjour @zebanx , @djidji59430

J'ai essayé de transposer votre code dans mon fichier réel, mais ça ne fonctionne pas...
Dans ma feuille 2 , je retrouve juste les entête

mapomme à dit:

Bonjour @elodieee, bienvenue sur XLD ,

Un essai par VBA. Cliquez sur le bouton HOP!
Le code est dans module1:

VB:

Sub test()
Dim t, s, i&, j&, n&

With Sheets("Feuil1")
  t = Range("c:c").Resize(Cells(Rows.Count, "c").End(xlUp).Row)
  ReDim v(1 To 3, 1 To 1)
  n = 1: v(1, n) = "SENDER": v(2, n) = "DEVISE": v(3, n) = "MONTANT"
  For i = 1 To UBound(t)
    s = Split(t(i, 1), Chr(10))
    If IsArray(s) Then
      For j = LBound(s) To UBound(s)
        If s(j) Like "SENDER : *" Then
          n = n + 1
          ReDim Preserve v(1 To 3, 1 To n)
          v(1, n) = Mid(s(j), Len("SENDER : "), 999)
          v(2, n) = Mid(s(j + 2), Len("DEVISE : "), 999)
          v(3, n) = CDbl(Replace(Mid(s(j + 1), Len("MONTANT : "), 999), ".", ","))
        End If
      Next j
    End If
  Next i
End With
With Sheets("RES")
  .Columns("a:c").Clear
  .Range("a1").Resize(UBound(v, 2), 3) = Application.Transpose(v)
  .Range("c1").Resize(UBound(v, 2)).NumberFormat = "0.00"
  .Select
End With
End Sub

edit : Bonjour @zebanx , @djidji59430

J'ai tenté de coller votre code dans mon fichier réel, et cela ne fonctionne pas...
Ca me rapporte bien SENDER MONTANT DEVISE dans la feuille 2 , mais c'est tout, pas d'autres infos...
Je ne connais pas VBA, pouvez juste me dire où se trouvent les infos que je dois modifier pour l'adapter au style de mon fichier?
Je vous remercie beaucoup !!!

Bonne journée

pierrejean · 14 Août 2019

Re

Salut djidji tapomme zebanx
@elodieee
Je suppose que ma version ne fonctionne pas non plus sur ton fichier réel
Le mieux est que tu nous montre la structure de ton fichier réel (une copie avec les données anonymisées de quelques lignes )

elodieee · 14 Août 2019

@pierrejean
En effet, ta version ne fonctionne pas non plus.
Je vous mets le fichier sur lequel je travaille, tu as raison ça sera plus simple

Amilo · 14 Août 2019

Bonjour à tous,
Une proposition avec power query
Cordialement

elodieee · 14 Août 2019

@Amilo
c'est parfait! Merci!
Mais je n'ai pas POWER ENQUIRY sur les pc du bureau, et interdiction d'installer des logiciels, je suis bloquée :'(

Amilo · 14 Août 2019

Re,
S'agit-il également d'une version Excel 2013 au travail ?
Sinon, Power query est un complément téléchargeable pour les versions 2010 et 2013 mais déjà intégré à partir d'Excel 2016
Je pourrais joindre une doc si vous voulez pour le téléchargement de power query mais à voir avant avec votre responsable pour l'autorisation
Sinon, c'est vraiment dommage de s'en priver
Cordialement

XL 2013 Extraire des données d'une cellule

elodieee

XLDnaute Nouveau

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

djidji59430

XLDnaute Barbatruc

Pièces jointes

pierrejean

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

zebanx

XLDnaute Accro

mapomme

XLDnaute Barbatruc

zebanx

XLDnaute Accro

elodieee

XLDnaute Nouveau

elodieee

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

elodieee

XLDnaute Nouveau

Pièces jointes

Amilo

XLDnaute Accro

Pièces jointes

elodieee

XLDnaute Nouveau

Amilo

XLDnaute Accro

Discussions similaires