XL 2010 Problème avec une expression régulière

Magic_Doctor · 22 Mai 2021

Bonjour,

J'essaie de dompter le Pattern suivant :
Je veux découper une chaîne de caractères de telle sorte que seuls les mots commençant par une majuscule et précédés d'un espace aillent, avec les textes en minuscules qui les suivent, à la ligne dans une même cellule.
Exemple : Romina Gudule aux grands pieds Cunégonde la folle Úrsula
Romina
Gudule aux grands pieds
Cunégonde la folle
Úrsula

VB:

Sub SuperposerItemsChaine()

Dim cel As Range, c As Range

    Application.ScreenUpdating = False
    For Each cel In Selection
        cel = Application.WorksheetFunction.Trim(cel)  'suppression de tous les éventuels espaces superflus de la chaîne
        With CreateObject("VBScript.RegExp")
            .Pattern = "( )([A-ZÀ-Ÿ])"  'un espace suivi d'une lettre majuscule. Tient compte des majuscules diacritées
            .IgnoreCase = False
            .Global = True
            For Each c In cel
                c.Value = .Replace(c.Value, "$1" & Chr(10) & "$2")
            Next
        End With
    Next
    [C2500].Select: Application.ScreenUpdating = True
End Sub

J'ai pratiquement résolu le problème, mais je me heurte avec les mots en minuscules commençant par une voyelle diacritée comme à é í ú etc.
Comment résoudre ce problème ?

job75 · 23 Mai 2021

Bonjour Magic_Doctor,

Avec ce code plus de problème :

VB:

Sub Copier_Coller()
    [Source].Offset(7) = [Source].Value
End Sub

Sub SuperposerItemsChaine()
Dim majuscules$, c As Range, t$, i%
    majuscules = "ABCDEFGHIJKLMNOPQRSTUVWXYZÀÁÂÃÄÅÒÓÔÕÖØÈÉÊËÌÍÎÏÙÚÛÜÑÇ"
    Application.ScreenUpdating = False
    For Each c In Selection
        t = " " & Application.Trim(Replace(c, vbLf, " "))
        For i = Len(t) To 2 Step -1
            If InStr(majuscules, Mid(t, i, 1)) And Mid(t, i - 1, 1) = " " Then t = Left(t, i - 2) & vbLf & Mid(t, i): i = i - 1
        Next i
        c = Mid(t, 2)
    Next c
    [C2500].Select
End Sub

A+

soan · 23 Mai 2021

Bonjour job75,

je crois bien que Magic_Doctor (salut) veut absolument utiliser les expressions régulières, donc avec ceci :

With CreateObject("VBScript.RegExp")

c'est car il fait des exos persos sur regexp : il veut obtenir son Doctorat Regexp, maîtrise Expert.

soan

job75 · 23 Mai 2021

Bonjour soan,

Les regexp c'est bien mais quand on peut les éviter c'est mieux

A+

soan · 23 Mai 2021

@job75 (salut Lionel)

oh oui, moi aussi, je trouve que c'est mieux si on peut éviter les regexp !

par contre, je ne maîtrise pas les désirs de Magic_Doctor !

ce que ~~femme veut~~ Magic_Doctor veut...

et puis sinon, j'aurais déjà proposé un fichier Excel depuis longtemps !

mais les regexp et moi, ça fait 2 !

soan

job75 · 23 Mai 2021

Maintenant Magic_Doctor si tu tiens aux RegExp utilise ce fichier (2) :

VB:

Sub Copier_Coller()
    [Source].Offset(7) = [Source].Value
End Sub

Sub SuperposerItemsChaine()
Dim cel As Range, c As Range
    Application.ScreenUpdating = False
    For Each cel In Selection
        cel = Application.WorksheetFunction.Trim(cel)  'suppression de tous les éventuels espaces superflus de la chaîne
        With CreateObject("VBScript.RegExp")
            .Pattern = "( )([A-Z]|[ÀÁÂÃÄÅÒÓÔÕÖØÈÉÊËÌÍÎÏÙÚÛÜÑÇ])"  'un espace suivi d'une lettre majuscule. Tient compte des majuscules diacritées
            .IgnoreCase = False
            .Global = True
            For Each c In cel
                c.Value = .Replace(c.Value, "$1" & vbLf & "$2")
            Next
        End With
    Next
    [C2500].Select
End Sub

soan · 23 Mai 2021

@job75 : j'en connais un qui va être ravi ! (n'est-ce pas Magic_Doctor ? )

job75 · 23 Mai 2021

Avec le fichier joint je peux comparer les 2 méthodes sur 5000 lignes, chez moi :

- avec RegExp 4,70 secondes

- sans RegExp 2,44 secondes, c'est presque 2 fois plus rapide.

Nota : RegExp prend du temps car il est recréé pour chaque ligne.

soan · 23 Mai 2021

@job75

j'adore ta comparaison des temps et l'info de ton Nota !

j'espère que Lionel (salut) ne sera pas jaloux si je t'ai attribué un "J'adore" :
d'habitude, c'est lui qui te met des "Like" !

(j'ai quelques scrupules à remplacer ton fan préféré ! )

soan

job75 · 23 Mai 2021

Voici les bonnes méthodes, avec utilisation d'un tableau VBA, fichier (2) :

VB:

Sub Copier_Coller()
    [Source].Offset(7) = [Source].Value
    With [Source].Offset(7).Resize([Source].Rows.Count)
        .AutoFill .Resize(1000 * .Rows.Count)
    End With
End Sub

Sub SuperposerItemsChaine_Avec_RegExp()
Dim dur, o As Object, tablo, i&, t$
dur = Timer
    Set o = CreateObject("VBScript.RegExp")
    o.IgnoreCase = False
    o.Global = True
    o.Pattern = "( )([A-Z]|[ÀÁÂÃÄÅÒÓÔÕÖØÈÉÊËÌÍÎÏÙÚÛÜÑÇ])"  'un espace suivi d'une lettre majuscule. Tient compte des majuscules diacritées
    With [Source].Offset(7).Resize(1000 * [Source].Rows.Count)
        tablo = .Value 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            t = Application.Trim(Replace(tablo(i, 1), vbLf, " "))
            tablo(i, 1) = o.Replace(t, "$1" & vbLf & "$2")
        Next
        .Value = tablo
    End With
MsgBox "Durée " & Format(Timer - dur, "0.00 \sec")
End Sub

Sub SuperposerItemsChaine_Sans_RegExp()
Dim dur, majuscules$, tablo, i&, t$, j%
dur = Timer
    majuscules = "ABCDEFGHIJKLMNOPQRSTUVWXYZÀÁÂÃÄÅÒÓÔÕÖØÈÉÊËÌÍÎÏÙÚÛÜÑÇ"
    With [Source].Offset(7).Resize(1000 * [Source].Rows.Count)
        tablo = .Value 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            t = " " & Application.Trim(Replace(tablo(i, 1), vbLf, " "))
            For j = Len(t) To 2 Step -1
                If InStr(majuscules, Mid(t, j, 1)) And Mid(t, j - 1, 1) = " " Then t = Left(t, j - 2) & vbLf & Mid(t, j): j = j - 1
            Next j
            tablo(i, 1) = Mid(t, 2)
        Next i
        .Value = tablo
    End With
MsgBox "Durée " & Format(Timer - dur, "0.00 \sec")
End Sub

Les 2 méthodes sont équivalentes => 1,80 seconde sur 5000 lignes chez moi.

Bernard_XLD · 23 Mai 2021

Bonjour le fil, le forum

@Magic_Doctor , tu n'étais vraiment pas loin, un caractère 221 au lieu d'un caractère 159 et ça aurait fonctionné comme tu le voulais !

Bien cordialement, @+

VB:

Sub SuperposerItemsChaine()

Dim cel As Range, c As Range

    Application.ScreenUpdating = False
    For Each cel In Selection
        cel = Application.WorksheetFunction.Trim(cel)  'suppression de tous les éventuels espaces superflus de la chaîne
        With CreateObject("VBScript.RegExp")
            .Pattern = "( )([A-ZÀ-Ý])"  'un espace suivi d'une lettre majuscule. Tient compte des majuscules diacritées
            .IgnoreCase = False
            .Global = True
            For Each c In cel
                c.Value = .Replace(c.Value, "$1" & Chr(10) & "$2")
            Next
        End With
    Next
    [C2500].Select: Application.ScreenUpdating = True
End Sub

job75 · 23 Mai 2021

Bonjour Yeahou,

Ah c'est bien vu, il fallait le trouver ce Ý.

J'ai vérifié, le Pattern récupère bien tous les caractères accentués, y compris Å Ø Ñ Ç.

Cela dit par rapport à la liste en dur la durée d'exécution est inchangée.

A+

Magic_Doctor · 23 Mai 2021

Bonjour job,

Merci pour tes prouesses. L'essentiel, c'est le résultat, peu importe la méthode.
En revanche, il est intéressant de constater à quel point les RegExp sont lentes.

Sacré soan ! Potache un jour, potache toujours !

soan · 23 Mai 2021

job75 · 23 Mai 2021

Magic_Doctor à dit:
En revanche, il est intéressant de constater à quel point les RegExp sont lentes.

Elles ne sont pas lentes si l'objet n'est créé qu'une fois, voir le post #10.

XL 2010 Problème avec une expression régulière

Magic_Doctor

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

soan

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Magic_Doctor

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

job75

XLDnaute Barbatruc