XL 2016 extraction de données

marc.gilliand

XLDnaute Occasionnel
Bonjour le forum,
1er exemple : j'ai une cellule qui contient la donnée suivante
Frisco Extrême Citron&Limes SL 16x145ml
je souhaite extraire dans deux colonnes séparées la valeur 16 et la valeur 145
2ème exemple :
Nuii MP WhiteChocolCranber 8x(4x90ml)
je souhaite extraire dans 3 colonnes séparées la valeur 8, la valeur 4 et la valeur 90

Merci de votre aide.
 
Solution
Bonjour marc.gilliand, JM,

Voyez le fichier joint et la macro affecté au bouton :
VB:
Sub Extraire()
Dim tablo, i&, x$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    For j = 1 To Len(x)
        y = Mid(x, j, 1)
        If y <> " " Then If Not IsNumeric(y) Then x = Replace(x, y, " ")
    Next j
    tablo(i, 1) = Application.Trim(x) 'SUPPRESPACE
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
A+

Staple1600

XLDnaute Barbatruc
Bonjour le fil, marc.gilliand

Pourquoi tu ne réutilises pas la formule que je t'ai proposée dans une autre de tes discussions ?
 

job75

XLDnaute Barbatruc
Bonjour marc.gilliand, JM,

Voyez le fichier joint et la macro affecté au bouton :
VB:
Sub Extraire()
Dim tablo, i&, x$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    For j = 1 To Len(x)
        y = Mid(x, j, 1)
        If y <> " " Then If Not IsNumeric(y) Then x = Replace(x, y, " ")
    Next j
    tablo(i, 1) = Application.Trim(x) 'SUPPRESPACE
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
A+
 

Pièces jointes

  • Extraire(1).xlsm
    18.4 KB · Affichages: 6

job75

XLDnaute Barbatruc
Fichier (2) avec cette macro plus rapide :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
Sur 50 000 lignes elle s'exécute en 0,5 seconde.
 

Pièces jointes

  • Extraire(2).xlsm
    18.8 KB · Affichages: 4

marc.gilliand

XLDnaute Occasionnel
Bonjour,
Merci de votre fichier. Malheureusement, le fait est que j'ai plein d'autres colonnes après la colonne valeur que je souhaite extraire. Et via la macro, tout a disparu. Je vous joins un bout de fichier.
Fichier (2) avec cette macro plus rapide :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
Sur 50 000 lignes elle s'exécute en 0,5 seconde.
Bonjour le forum
Merci, je vous joins un bout de mon fichier. Car j'ai des colonnes à préserver. Voici le lien :
Fichier (2) avec cette macro plus rapide :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
Sur 50 000 lignes elle s'exécute en 0,5 seconde.
Bonjour,
Je souhaiterai vous envoyer un bout de mon fichier, qui contient des Recherchev, des SI, etc... mais le fichier est trop lourd. Quel est le nom du site pour partager des fichiers. Merci d'avance
 

marc.gilliand

XLDnaute Occasionnel
Bonjour,
Merci de votre fichier. Malheureusement, le fait est que j'ai plein d'autres colonnes après la colonne valeur que je souhaite extraire. Et via la macro, tout a disparu. Je vous joins un bout de fichier.
Fichier (2) avec cette macro plus rapide :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("B").Resize(, Columns.Count - 1).Delete 'RAZ
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [B1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
Sur 50 000 lignes elle s'exécute en 0,5 seconde.

Bonjour,
Je souhaierai vosu envoyer une partie de mon fichier, car trop lourd en l'état pour vous l'envoyer, le site cjoint ne fonctionne-t-il plus ?
 

Staple1600

XLDnaute Barbatruc
Re, Bonjour Job75

=>marc
[Pour infos]
On joint un fichier allégé (jamais l'original)
Et cette version allégée qui illustre le problème, tu peux la compresser dans un fichier zip
Et joindre ce zip sur le forum

NB: D'autant que la charte du forum déconseille d'héberger les fichiers exemple ailleurs que dans les discussions du forum.
 

marc.gilliand

XLDnaute Occasionnel
Voici mon
Bonjour,
Merci de votre fichier. Malheureusement, le fait est que j'ai plein d'autres colonnes après la colonne valeur que je souhaite extraire. Et via la macro, tout a disparu. Je vous joins un bout de fichier.


Bonjour,
Je souhaierai vosu envoyer une partie de mon fichier, car trop lourd en l'état pour vous l'envoyer, le site cjoint ne fonctionne-t-il plus ?
Bonjour,

Voici mon fichier ZIP. Merci d'avance de votre aide.
 

Pièces jointes

  • Froneri_Toute_la_gamme_V5.zip
    899.6 KB · Affichages: 1

job75

XLDnaute Barbatruc
Il suffit d'adapter pour restituer la colonne X à partir de la colonne AO :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("AO").Resize(, Columns.Count - Columns("AO").Column + 1).ClearContents 'RAZ
tablo = [A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 24) 'colonne X
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [AO1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
 

Pièces jointes

  • Froneri_Toute_la_gamme_V5.zip
    955.6 KB · Affichages: 3

marc.gilliand

XLDnaute Occasionnel
Il suffit d'adapter pour restituer la colonne X à partir de la colonne AO :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, z$, j%, y$
Application.ScreenUpdating = False
Columns("AO").Resize(, Columns.Count - Columns("AO").Column + 1).ClearContents 'RAZ
tablo = [A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 24) 'colonne X
    deb = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) Then deb = j
        If deb Then If Not IsNumeric(y) Then z = z & " " & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = LTrim(z)
Next i
'---restitution---
With [AO1].Resize(i - 1)
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Space:=True 'commande Convertir
End With
End Sub
Bonjour,
Merci, le seul hic, c'est que je souhaite que l'extraction de ces données ne soient pas en AO AP AQ, mais en Y, Z et AA. Merci de votre aide.
 

marc.gilliand

XLDnaute Occasionnel
Bonjour,
Merci, le seul hic, c'est que je souhaite que l'extraction de ces données ne soient pas en AO AP AQ, mais en Y, Z et AA. Merci de votre aide.
Re-Bonjour,
Et lorsque je rajoute des données, XL m'efface complètement toutes les données. Bizarre. N'y a-t-il pas un moyen pour qu'à l'ouverture du fichier les remontées ne se calculent pas et que c'est seulement qu'une fois que j'active la macro que celle-ci s'exécute ? Merci de votre aide.
 

job75

XLDnaute Barbatruc
Bon on y arrive :
VB:
Sub Extraire()
Dim tablo, i&, x$, deb%, n%, z$, j%, y$
tablo = [A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 24) 'colonne X
    deb = 0: n = 0: z = ""
    For j = 1 To Len(x) + 1
        y = Mid(x, j, 1)
        If deb = 0 Then If IsNumeric(y) And n < 3 Then n = n + 1: deb = j 'limite de 3 nombres
        If deb Then If Not IsNumeric(y) Then z = z & Chr(1) & Mid(x, deb, j - deb): deb = 0
    Next j
    tablo(i, 1) = Mid(z, 2)
Next i
'---restitution---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With [Y1].Resize(i - 1) '1ère colonne de restitution
    tablo(1, 1) = .Cells(1, 1) & Chr(1) & .Cells(1, 2) & Chr(1) & .Cells(1, 3) 'titres
    .Value = tablo
    .TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
End With
End Sub
Le nombre d'extractions est limité à 3.

La macro s'exécute seulement quand on clique sur le bouton. Extraire
 

Pièces jointes

  • Froneri_Toute_la_gamme_V6.zip
    956.4 KB · Affichages: 2
Dernière édition:

job75

XLDnaute Barbatruc
Finalement plutôt qu'une procédure Sub il vaut mieux une fonction VBA :
VB:
Function Extract(x$)
Dim a(1 To 3), i%, y$, deb%, n%
a(1) = "": a(2) = "": a(3) = "" 'pour éviter les valeurs zéro
For i = 1 To Len(x) + 1
    y = Mid(x, i, 1)
    If deb = 0 Then If IsNumeric(y) And n < 3 Then n = n + 1: deb = i 'limite de 3 nombres
    If deb Then If Not IsNumeric(y) Then a(n) = Val(Mid(x, deb, i - deb)): deb = 0
Next i
Extract = a 'vecteur ligne
End Function
Le code doit être placé impérativement dans un module standard.

Sélectionnez Y2:AA2, entrez la formule =Extract(X2) dans la barre de formule et validez en bloc matriciellement par Ctrl+Maj+Entrée puis tirez Y2:AA2 vers le bas.
 

Pièces jointes

  • Froneri_Toute_la_gamme_V7.zip
    955.1 KB · Affichages: 3

marc.gilliand

XLDnaute Occasionnel
Finalement plutôt qu'une procédure Sub il vaut mieux une fonction VBA :
VB:
Function Extract(x$)
Dim a(1 To 3), i%, y$, deb%, n%
a(1) = "": a(2) = "": a(3) = "" 'pour éviter les valeurs zéro
For i = 1 To Len(x) + 1
    y = Mid(x, i, 1)
    If deb = 0 Then If IsNumeric(y) And n < 3 Then n = n + 1: deb = i 'limite de 3 nombres
    If deb Then If Not IsNumeric(y) Then a(n) = Val(Mid(x, deb, i - deb)): deb = 0
Next i
Extract = a 'vecteur ligne
End Function
Le code doit être placé impérativement dans un module standard.

Sélectionnez Y2:AA2, entrez la formule =Extract(X2) dans la barre de formule et validez en bloc matriciellement par Ctrl+Maj+Entrée puis tirez Y2:AA2 vers le bas.

C'est parfait, je vous remercie infiniment. C'est génial
 

Discussions similaires

Statistiques des forums

Discussions
311 732
Messages
2 081 995
Membres
101 857
dernier inscrit
mt60400