XL 2016 Extraire plusieurs données d'une même cellule

lindoux

XLDnaute Nouveau
Bonjour,

Je souhaite extraire d'une cellule A1 toutes les données commençant par "90AA"ainsi que les 10 chiffres suivants dans une nouvelle feuille en A1, A2 , A3...
Je vous joins un extrait du fichier.

Le fichier d'origine (provient d'1 EDI) comporte +100 000 lignes et chaque ligne n'a pas le même nombre de caractères.

J'ai essayé de faire une macro, mais cela n'a pas fonctionné (en même temps, je ne suis pas une pro là dessus)

J'espère que vous pourrez m'aider
 

Fichiers joints

sousou

XLDnaute Barbatruc
Bonjour
un code à adapter, ici fonctionne avec la cellule active pour tester
Sub test()
With ActiveCell
n = 1: vtest = "90AA": compte = 0
While n <> 0
n = InStr(n, .Value, vtest)
If n <> 0 Then
valeur = Mid(.Value, n, 14)
compte = compte + 1: n = n + 1
Call ecrire(valeur, compte)
End If

Wend
End With
End Sub
Sub ecrire(v, c)
Sheets(2).Cells(c, 1) = v
End Sub
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Voir le fichier joint. Cliquez sur le bouton Extraire de la feuille Extract. Environ 10 secondes pour 100.000 lignes.
Le code est dans le Module1:
VB:
Sub Extraction_90AA()
Const max = 15000
Dim derlig&, deb&, ncol&, n&, i&, j&, nfois, x, t, res(), T0

T0 = Timer
Application.ScreenUpdating = False
With Sheets("Feuil1")
   If .FilterMode Then .ShowAllData
   derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
   deb = 1
   Do
      nfois = nfois + 1: t = .Cells(deb, "a").Resize(max)
      ReDim res(1 To max, 1 To 1)
      For i = 1 To UBound(t)
         j = 1: n = 0: x = t(i, 1)
         If x <> "" Then
            Do
               j = InStr(j, x, "90AA", vbTextCompare)
               If j > 0 Then
                  n = n + 1
                  If n > UBound(res, 2) Then ReDim Preserve res(1 To UBound(res), 1 To UBound(res, 2) + 1)
                  res(i, n) = Mid(x, j, 14)
                  j = j + 10
               Else
                  Exit Do
               End If
            Loop
         End If
      Next i
      With Sheets("Extract")
         If nfois = 1 Then .Range("a1").CurrentRegion.Clear
         .Range("a1").Offset(max * (nfois - 1)).Resize(max, UBound(res, 2)) = res
         .Range("a1").CurrentRegion.EntireColumn.AutoFit
      End With
      If max * nfois >= derlig Then Exit Do
   Loop
End With
MsgBox "Durée: " & Format(Timer - T0, "0.00\ sec.")
End Sub
edit: bonjour @sousou ;)
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonsoir lindoux, sousou, mapomme, fanfan38,

On peut utiliser cette fonction VBA :
VB:
Function Extract$(txt$, critere$, n%, ordre%)
Dim s
s = Split(txt, critere)
If ordre <= UBound(s) Then Extract = critere & Left(s(ordre), n)
End Function
Voyez le fichier joint et cette formule en B2 à tirer vers la droite =Extract($A2;"90AA";10;COLONNE()-1)

Pour tester sur 100 000 lignes exécutez cette macro :
Code:
Sub Test()
Dim t
t = Timer
[A2:F2].AutoFill [A2:F100001]
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub
Chez moi sur Win 10 - Excel 2019 et une RAM de 8 Go la durée d'exécution est de 4,7 secondes.

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour le forum,

La solution de mon post #5 est incomplète car on ne connaît pas a priori le nombre de colonnes des résultats.

Ce fichier (2) de 100 000 lignes va mieux avec la macro :
VB:
Sub Extraire()
Dim t, critere$, n%, tablo, nlig&, i&, s, ub%, ubmax%, resu(), j%
t = Timer
critere = "90AA" 'à adapter
n = 10 'à adapter
tablo = [A1].CurrentRegion.Columns(1) 'matrice, plus rapide
If Not IsArray(tablo) Then Exit Sub 'si tableau vide
nlig = UBound(tablo)
'---tableau des résultats---
For i = 2 To nlig
    s = Split(tablo(i, 1), critere)
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(1 To nlig, 1 To ub)
    For j = 1 To ub
        resu(i, j) = critere & Left(s(j), n)
Next j, i
'---restitution---
With Feuil1 'CodeName de la feuille de restitution, à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[B1] 'adaptable
        If ubmax Then
            .Resize(nlig, ubmax) = resu
            .Value = "Extract " & 1: .Cells.AutoFill .Resize(, ubmax)
        End If
        .Offset(, ubmax).Resize(, .Parent.Columns.Count - ubmax - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub
Chez moi sur Win 10 Excel 2019 la macro s'exécute en 1,20 seconde.

A+
 

Fichiers joints

lindoux

XLDnaute Nouveau
Bonjour à tous :)

Merci mille fois pour vos réponses, ça fonctionne super bien :)))

Est-il possible de faire un rajout sur cette macro pour un copier coller transposé sur une nouvelle feuille?

Merci encore, vous m'avez fait gagné un temps énorme :)
 

job75

XLDnaute Barbatruc
Si l'on veut tout récupérer dans la feuille "Extraction" voyez ce fichier (3) et la macro :
VB:
Sub Extraire()
Dim t, critere$, n%, tablo, nlig&, i&, s, ub%, ubmax%, resu(), j%
t = Timer
critere = "90AA" 'à adapter
n = 10 'à adapter
tablo = [A1].CurrentRegion.Columns(1) 'matrice, plus rapide
If Not IsArray(tablo) Then GoTo 1 'si tableau vide
nlig = UBound(tablo)
'---tableau des résultats---
For i = 2 To nlig
    s = Split(tablo(i, 1), critere)
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(1 To nlig, 1 To ub)
    For j = 1 To ub
        resu(i, j) = critere & Left(s(j), n)
Next j, i
'---restitution---
1 With Sheets("Extraction") 'feuille de restitution, à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1] 'adaptable
        If nlig Then .Resize(nlig) = tablo
        If ubmax Then
            With .Cells(1, 2)
                .Resize(nlig, ubmax) = resu
                .Value = "Extract " & 1: .Cells.AutoFill .Resize(, ubmax)
                .Resize(, ubmax).EntireColumn.AutoFit 'ajustement largeur
            End With
        End If
        .Offset(, ubmax + 1).Resize(, .Parent.Columns.Count - ubmax - .Column).EntireColumn.Delete 'RAZ à droite
        .Offset(nlig).Resize(.Parent.Rows.Count - nlig - .Row + 1).EntireRow.Delete 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub
Cela prend un peu plus de temps (1,80 seconde) car il faut récupérer la 1ère colonne.

A+
 

Fichiers joints

Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas