XL 2013 Extraire des données d'une cellule

[elodieee]

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]

Bonjour @elodieee, bienvenue sur XLD ,

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

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]

Bonjour à tous,

un autre par formule :

 

[pierrejean]

Bonsoir à tous

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

 

[mapomme]

Bonsoir @pierrejean ,

 

[zebanx]

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]

Re @zebanx ,

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]

Super Mapomme.

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

Bonne nuit

 

[elodieee]

Bonjour @elodieee, bienvenue sur XLD ,

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

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]

Bonjour @elodieee, bienvenue sur XLD ,

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

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

Bonjour @elodieee, bienvenue sur XLD ,

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

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]

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]

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

Bonjour à tous,
Une proposition avec power query
Cordialement

 

[elodieee]

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

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