Macro pour extraire des nombres situés avant un texte spécifique

Question

Je suis débutante en VBA et j'essaie de trouver une macro me permettant d'extraire des nombres qui apparaîtront toujours après une phrase spécifique dans la chaîne. La chaîne ressemble à ce qui suit (mais peut varier en fonction des produits achetés). Il s'agit d'une liste de produits qui ont été achetés par un client avec les quantités précédentes. Ex : "65x Gazon en rouleaux(id:1) | 1x Engrais d'entretien Sac jusqu'à 200m²(id:5) | 1x Engrais starter Sac jusqu'à 80m²(id:4)" Signification : le client a acheté 65 gazons en rouleaux, 1 engrais entretien, 1 engrais starter. Le souci est que la longueur des chiffres varie et la liste des produits aussi. C'est pourquoi je ne peux pas faire de fractionnement et la macro doit trouver le texte spécifique dans la chaîne pour extraire le bon numéro et le placer dans la bonne colonne. Par exemple, nous pouvons avoir des cas comme ci-dessous : Seulement 2 produits achetés : "34x Gazon en rouleaux(id:1) | 1x Engrais starter Sac jusqu'à 80m²(id:4)" Seulement 1 produit acheté : "350x Gazon en rouleaux(id:1)" L'objectif serait que la macro recherche le nom du produit ("Gazon en rouleaux" par ex) et renvoie la quantité située avant ce texte ("65" dans le cas du premier exemple) dans une colonne Quantité Gazon. Idem pour engrais starter et entretien. J'ai essayé d'utiliser plusieurs macros trouvées sur le web mais elles ne correspondaient pas à ma demande exacte et je n'ai pas pu les personnaliser car je suis trop débutante. Ci-dessous une des macros qui semblait répondre à mon besoin. Sub GetPrice() Dim sExpression As String Dim sPhrase As String Dim LenPhrase As Long Dim NumStart As Long Dim NumLen As Long sExpression = "19 apples with price of $0.30 and use by date of 31 July 2016" sPhrase = "price of" LenPhrase = Len(sPhrase) NumStart = InStr(sExpression, sPhrase) + LenPhrase + 1 NumLen = InStr(Right(sExpression, Len(sExpression) - NumStart), " ") Debug.Print Mid(sExpression, NumStart, NumLen) End Sub Un grand merci par avance pour votre aide...

BsAlv · Accepted Answer

@Bruno, j'ai des problèmes avec transpose (ça cause des problèmes à partir de 65k, ce qui n'est pas le cas ici) et a redimensioner à chaque fois (cela ralentit le procès), donc moi, j'exagère une fois, le maximum maximorum. @Gabrielle; vous demandez ce que @Dan a fait, mais chaque colonne encore divisé en 2 ??? Sub Unpivot2() Dim aA, OUT, i, j, ptr, ptr_MAX With Sheets("Feuil1") aA = .Range("A1").CurrentRegion.Resize(, 1).Value2 ReDim OUT(1 To UBound(aA), 100) 'en exagérant, 2 colonne par article, donc max 50 articles par ligne (si cela ne suffit pas change ce 100) For i = 2 To UBound(aA) sp = Split(aA(i, 1), "|") ptr = 0 OUT(i - 1, 0) = i For j = 0 To UBound(sp) sp1 = Split(Trim(sp(j)), " ", 2) If StrComp(Right(sp1(0), 1), "x", 1) = 0 And UBound(sp1) = 1 Then 'vérifier si le texte consiste de &gt;=2 mots et le dernier charactère du premier mot est un x OUT(i - 1, ptr + 1) = Left(sp1(0), Len(sp1(0)) - 1): OUT(i - 1, ptr + 2) = sp1(1) Else OUT(i - 1, ptr + 2) = sp(j) End If ptr = ptr + 2: ptr_MAX = Application.Max(ptr_MAX, ptr) Next Next With .Range("M1") .CurrentRegion.ClearContents If UBound(aA) &gt; 1 Then With .Resize(UBound(aA) - 1, ptr_MAX + 1) .Value = OUT .EntireColumn.AutoFit End With End If End With End With End Sub...

Invité · Answer

Une petite présentation ICI serait la bienvenue Si vous ne l'avez pas encore fait, je vous invite à lire la charte du forum &#91;A LIRE AVANT DE POSTER&#93; qui vous aidera dans vos demandes et réponses sur ce forum (comme mettre le code entre balises ) Ainsi que sur les fonctionnalités (Nouveau Forum au bas de page notamment) Merci de votre participation Cordialement...

JFL · Answer

Et... Il serait opportun de préciser, dans le profil, la nature de votre produit Excel. La langue n'est pas un élément important. Sinon, Power Query (complément gratuit à installer pour Excel 2010 et 2013 - Nativement intégré dans les versions postérieures) vous donne, en quelques clics (3 !) le résultat attendu...

Dan · Answer

La demande me parait pourvoir être réalisée avec l'option Convertir du menu données, si on prend ce critère --&gt; | qui sépare chaque phrase Dans le fichier joint le code ci-dessous fait cela : Sub test() Dim plage As Range Set plage = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) plage.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _ TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _ :=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", _ FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True End Sub Bruno, tu as une autre idée ? Cordialement Edit : oups bonjour JFL, désolé je n'avais pas regardé que vous aviez posté. Et de plus je pense ne pas avoir répondu complètement à la question.....

JFL · Answer

Ne le soyez pas ! Il m'arrive (trop...) souvent de poster sans procéder au rafraichissement nécessaire... Par ailleurs, je trouve toujours pertinent pour le demandeur de pouvoir choisir entre différentes options. Alors... VBA, Formules et autres propositions......ne faisons pas la fine bouche...

JFL · Answer

Alors, je vous laisse entre les mains des spécialistes. Ils sont nombreux ici.....

BsAlv · Answer

Sub Unpivot() Dim aA, Dict, i, j Set Dict = CreateObject("scripting.dictionary") With Sheets("Feuil1") aA = .Range("A1").CurrentRegion.Resize(, 1).Value2 For i = 2 To UBound(aA) sp = Split(aA(i, 1), "|") For j = 0 To UBound(sp) sp1 = Split(Trim(sp(j)), " ", 2) If StrComp(Right(sp1(0), 1), "x", 1) = 0 And UBound(sp1) = 1 Then Dict.Add Dict.Count, Array(i, sp1(0), sp1(1)) Else Dict.Add Dict.Count, Array(i, "", sp(j)) End If Next Next With .Range("F1") .Resize(, 3).EntireColumn.ClearContents .Resize(Dict.Count, 3).Value = Application.Index(Dict.items, 0, 0) .Resize(, 3).EntireColumn.AutoFit End With End With End Sub...

Invité · Answer

Si vous êtes sur Mac, pas de chance, le code de BsAlv ne fonctionne que sur PC avec Windows car il fait appel à un composant ActiveX présent uniquement sur Windows Sur une partie de l'idée de BsAlv (que je salue) voici un code qui devrait fonctionner sans problème Sub Extraction() Dim Lig As Long, Ind As Long, Ind2 As Long Dim TabLst As Variant, TabArt As Variant, TabExt() As String Dim sQt As String, sDes As String ' Avec la feuille nommée With Sheets("Feuil1") ' créer le tableau de la liste d'article TabLst = .Range("A1").CurrentRegion.Resize(, 1).Value2 ' Pour chque ligne du tableau For Lig = 2 To UBound(TabLst) ' On sépare chaque type d'article TabArt = Split(TabLst(Lig, 1), " | ") ' On met les quantité et la designation dans 2 colonnes For Ind = 0 To UBound(TabArt) ' On récupère la Quantité et la désignation sDes = TabArt(Ind): sQt = Left(sDes, InStr(1, sDes, " ") - 2) sDes = Mid(sDes, Len(sQt) + 3) ' On incrémente le futur nouveau tableau Ind2 = Ind2 + 1 ' On le redimensionne en conservant les valeurs existantes ReDim Preserve TabExt(2, Ind2) ' On ajoute la Qt et la Désignation chacune dans une colonne TabExt(1, Ind2) = sQt: TabExt(2, Ind2) = sDes Next Ind Next Lig ' A partir de la cellule C1 With .Range("C1") ' On efface ce qui existait déjà .Resize(, 2).EntireColumn.ClearContents ' On inscrit le tableau .Resize(Ind2 + 1, 3).Value = Application.Transpose(TabExt) End With End With End Sub A+...