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

[Magic_Doctor]

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

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]

Bonjour Magic_Doctor,

Avec ce code plus de problème :

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]

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]

Bonjour soan,

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

A+

 

[soan]

@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]

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

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]

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

 

[job75]

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]

@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]

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

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]

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, @+

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]

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]

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]

 

[job75]

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.