Extraire un groupe de caractères vers une seule cellule, selon condition

[Nougatine95]

Bonsoir Le Forum,

Après avoir ouvert des dizaines de posts afin d'y trouver une équivalence à ma recherche, je capitule.

Ma requête:
Extraire un groupe de caractères (caractères issus d'une chaîne de texte), vers une seule cellule, selon condition.

Petit fichier joint.
Il n'y a pas d'urgence!

En vous remerciant.

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Sur mon portable avec Win 7 - Excel 2010 c'est un peu plus rapide :

David84 => 14,21 secondes (macro du post #7 bien sûr)

job75 => 8,02 secondes.

A+

 

[Staple1600]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re

Re,

Avec la macro de David du post #13 => 9 minutes 19 secondes

Cela confirme que regexp est fort peu brillant en terme de durée d'exécution.

A+

Ce serait peut-être plus rapide en passant par une Sub et pas par une fonction ?

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Bonsoir Jean-Marie

Ce serait peut-être plus rapide en passant par une Sub et pas par une fonction ?

Peut-être, mais plusieurs tests réalisés par Boisgontier et moi-même montrent que RegExp est toujours 60 fois plus lent que les meilleures méthodes.

A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Je viens de modifier la macro du post #10, j'avais écrit :

Crochets = Mid(Crochets, 3 + (Left(t, 1) = "["))

alors qu'il fallait :

Crochets = Mid(Crochets, 3 + (Left(Crochets, 1) = "["))

Bien entendu cela ne change en rien la durée d'exécution.

A+

 

[Staple1600]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re

Job75:
Est-ce "l'objet RegExp" qui n'est pas rapide ou Excel qui n'est pas rapide avec cet objet qui n'est pas "natif VBA" ?

Car dans d'autres langages RegeExp est très utilisé et/ou apprécié.

 

[david84]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Avec la macro de David du post #13 => 9 minutes 19 secondes

Cela confirme que regexp est fort peu brillant en terme de durée d'exécution.

A+

Effectivement et ce n'est pas nouveau : le RegExp est un outil très puissant mais très lent.
Il n'est pas fait pour travailler sur un nombre important de cellules mais est plutôt utilisé pour valider des chaînes de caractères particulières au sein de contrôles de formulaire par exemple.
C'est d'ailleurs comme cela qu'il est utilisé dans la plupart des langages de programmation et là c'est un outil vraiment intéressant car plus direct et plus précis que d'autres procédures (normal car il est fait spécialement pour cela).

Pour en revenir la présente fonction on peut peut-être réduire un peu le temps de traitement en la validant sur une matrice et non cellule par cellule (mais je n'ai pas testé donc je n'en suis pas sûr) :

Function RegrouperCarMat(c As String)
Dim Reg As Object, Matches As Object, i As Integer, Tablo() As String
If c = vbNullString Then Exit Function
Set Reg = CreateObject("vbscript.regexp")
With Reg
  .Global = True
  .IgnoreCase = True
  .Pattern = "([A-Z]|[[A-Z]+])"
  If .test(c) = True Then Set Matches = .Execute(c)
End With
ReDim Tablo(0 To Application.Caller.Columns.Count - 1)
For i = 0 To Application.Min(Matches.Count - 1, UBound(Tablo))
  Tablo(i) = Matches.Item(i)
  If Len(Tablo(i)) > 1 Then Tablo(i) = Replace(Replace(Tablo(i), "[", ""), "]", "")
Next i
RegrouperCarMat = Tablo
End Function

A+

 

[mapomme]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Bonjour Nougatine95, le forum,

Une version avec une procédure au lieu de fonction.

• sélectionner la zone à traiter
• cliquer sur le bouton orange

ou bien

• cliquer sur le bouton gris
• indiquer le nombre de ligne à construire. La zone est automatiquement construite et sélectionnée
• cliquer sur le bouton orange

Sur ma bécane, le traitement de 20 000 lignes dure à peu près 12 secondes.

Edit: préférer la v2 qui corrige un bug (texte vide entre crochet)

Le code dans module1:

Sub Ventiler()
Dim xrg As Range, Deb!
Dim S(), T() As String, R() As String, i&, i1&, i2&, j&, j1&, k&, m&

'vérif sélection
If Selection.Columns.Count <> 1 Then
  MsgBox "La selection ne doit comporter qu'une seule colonne"
  Exit Sub
ElseIf Selection.Rows.Count <= 1 Then
  MsgBox "La selection doit comporter au moins deux lignes " & _
      "(vides ou non)"
  Exit Sub
End If

'Traitement
Deb = Timer
  With Selection
    .Offset(, 1).Resize(, 1000).EntireColumn.Clear
    Application.ScreenUpdating = False
    S = .Value: i2 = UBound(S)
    For i = 1 To i2
      T = Split(StrConv(S(i, 1), vbUnicode), Chr$(0))
      j1 = UBound(T) - 1
      If j1 >= 0 Then
        ReDim Preserve T(j1)
        ReDim R(j1)
        j = 0: k = -1
        Do Until j > j1
          If T(j) <> "[" Then
            k = k + 1: R(k) = T(j): j = j + 1
          ElseIf T(j) = "[" Then
            j = j + 1: k = k + 1
            Do Until T(j) = "]"
              R(k) = R(k) & T(j): j = j + 1
            Loop
            If R(k) = "" Then k = k - 1
            j = j + 1
          End If
        Loop
      .Offset(i - 1, 1).Resize(1, UBound(R) + 1).Value = R
      End If
    Next i
  End With
Application.ScreenUpdating = True
MsgBox Format(Timer - Deb, "0.0") & " sec."
End Sub

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Bonjour David, le fil, forum,

J'ai eu la même idée en me réveillant ce matin, donc fonction matricielle dans ce fichier (3) :

Function Crochets(t$)
Dim d%, tablo$(), i%, x$, grp As Boolean, n%
d = Application.Caller.Count
ReDim tablo(d - 1) 'vecteur horizontal base 0
For i = 1 To Len(t)
  x = Mid(t, i, 1)
  If Not grp And x <> "[" Then
     tablo(n) = x
     n = n + 1
  ElseIf x <> "]" Then
    grp = True
    tablo(n) = tablo(n) & x
  Else
    grp = False
    tablo(n) = Mid(tablo(n), 3 + (Left(tablo(n), 1) = "["))
    n = n + 1
  End If
  If n = d Then Exit For
Next
Crochets = tablo
End Function

Entrer =Crochets($A21) dans toute la plage A21:Q21 et valider matriciellement par Ctrl+Maj+Entrée.

Puis tirer toute la plage vers le bas.

Sur 20000 lignes la durée d'exécution est de 2,38 secondes (Win XP - Excel 2003).

La macro du post #21 de David s'exécute en 38 secondes, c'est pas mal pour RegExp....

Edit : bonjour mapomme, je ne t'avais pas vu.

A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Avec la variable y cette macro est plus logique et un chouïa plus rapide (2,33 secondes) :

Function Crochets(t$)
Dim d%, tablo$(), i%, x$, grp As Boolean, n%, y$
d = Application.Caller.Count
ReDim tablo(d - 1) 'vecteur horizontal base 0
For i = 1 To Len(t)
  x = Mid(t, i, 1)
  If Not grp And x <> "[" Then
     tablo(n) = x
     n = n + 1
  ElseIf x <> "]" Then
    grp = True
    y = y & x
  Else
    grp = False
    tablo(n) = Mid(y, 2)
    y = ""
    n = n + 1
  End If
  If n = d Then Exit For
Next
Crochets = tablo
End Function

Fichier (4).

A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Tiens c'est vraiment curieux.

J'ai limité le tableau aux colonnes strictement nécessaires c'est à dire A:N.

Et j'ai même dans la macro retiré le test If n = d Then Exit For.

Eh bien c'est plus long : 2,40 secondes

A+

 

[david84]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Bonjour,
une autre proposition de fonction personnalisée matricielle à tester :

Function RegrouperCarMat2(c As String)
Dim i%, j%, t$(), n%
ReDim t(1 To Application.Caller.Count)
j = 1
For i = 1 To UBound(t)
  If Mid(c, j, 1) = "[" Then
    n = InStr(j, c, "]")
    t(i) = Mid(c, j + 1, n - j - 1): j = n + 1
  Else
      t(i) = Mid(c, j, 1): j = j + 1
  End If
Next i
RegrouperCarMat2 = t
End Function

A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Bien sûr que je me suis empressé de tester David.

Un chouïa moins rapide que ma macro du post #24 => 2,38 seconde.

Mais ne pinaillons pas, c'est du kif-kif et la macro est plus courte

A+

 

[david84]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re,

Bien sûr que je me suis empressé de tester David.

Un chouïa moins rapide que ma macro du post #24 => 2,38 seconde.

Mais ne pinaillons pas, c'est du kif-kif et la macro est plus courte

A+

Arghhh (dixit Modeste) !!!
Bon, j'ai fini par tester chez moi : ton code du #24 : 1.59s, le mien 1.63s.
Je peux peut-être l'améliorer aux entournures mais pas non plus de manière significative...
A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re David,

J'ai juste ajouté un test sur ta macro :

Function RegrouperCarMat2(c As String)
Dim i%, j%, t$(), n%
ReDim t(1 To Application.Caller.Count)
j = 1
For i = 1 To UBound(t)
  If Mid(c, j, 1) = "[" Then
    n = InStr(j, c, "]")
    t(i) = Mid(c, j + 1, n - j - 1)
    j = n + 1
  Else
    t(i) = Mid(c, j, 1)
    If t(i) = "" Then Exit For
    j = j + 1
  End If
Next i
RegrouperCarMat2 = t
End Function

Soit content, maintenant c'est bien la meilleure : 2,25 secondes

Fichier joint.

A+

 

[job75]

Re : Extraire un groupe de caractères vers une seule cellule, selon condition

Re David,

J'utilise maintenant InStr mais je ne fais pas la même boucle que toi, je n'ai besoin que d'un seul test :

Function Crochets(t$)
Dim tablo$(), i%, x$, n%, j%
ReDim tablo(Application.Caller.Count - 1) 'base 0
For i = 1 To Len(t)
  x = Mid(t, i, 1)
  If x <> "[" Then
    tablo(n) = x
  Else
    j = InStr(i, t, "]")
    tablo(n) = Mid(t, i + 1, j - i - 1)
    i = j
  End If
  n = n + 1
Next
Crochets = tablo
End Function

Durée d'exécution 2,16 secondes, ça devient du pinaillage

Fichier (5).

A+