XL 2019 Retirer un mot dans un pavé de cellules contenant des Vblf

[Webperegrino]

Bonjour Le Forum,

Des commandes vba m’extraient correctement une liste de prénoms dans le pavé [D9 : D33] pour une recherche avec un prénom en [B4].

En complément, je désire réaliser quelques lignes vba pour retirer le prénom dans le pavé [D9 : D33]

Ce prénom figure en effet selon les cas suivants :

• 1 - seul dans la cellule
• 2 - au début, avec un retour à la ligne
• 3 - entre deux retours à la ligne
• 4 - ou à la fin, après un retour à la ligne

J’ai élaboré un commencement mais je m’aperçois que ces lignes VBA ne résolvent pas tous les cas ci-dessus énoncés, même avec une solution de JOB75 qui ne traite pas le cas n° 3.

Merci pour votre aide, et si vous avez des lignes de codes qui seraient encore plus efficaces et plus rapides n’hésitez pas à me corriger cela et m’en faire un peu de pédagogie (que j’en comprenne le fonctionnement).

Belle journée,
Webperegrino

 

[job75]

Bonjour Webperegrino, le forum,

Wouah ! 3 secondes !

Qu'est-ce que c'est que cette histoire de plusieurs secondes alors qu'il n'y a que quelques cellules à traiter ?

Avec cette macro qui utilise des tableaux VBA l'exécution est instantanée :

Sub Suppr_Prenom()
Dim sup$, deb As Range, tablo, ub&, i&, s, a(), n%, j%
With ActiveSheet 'à adapter
    sup = .[B4] 'prénom à supprimer
    Set deb = .[D9]
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .Range(deb, .Cells(.Rows.Count, deb.Column).End(xlUp))
        tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
        ub = UBound(tablo)
        For i = 1 To UBound(tablo)
            s = Split(tablo(i, 1), vbLf)
            Erase a: n = 0
            For j = 0 To UBound(s)
                If s(j) <> "" And s(j) <> sup Then
                    ReDim Preserve a(n)
                        a(n) = s(j)
                        n = n + 1
                End If
            Next j
            tablo(i, 1) = Join(a, vbLf)
        Next i
    End With
    With .[F9] '1ère cellule de destination, à adapter
        .Resize(ub) = tablo
        .Offset(ub).Resize(.Parent.Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
    End With
End With
End Sub

Pour tester j'ai recopié les lignes 9:12 du fichier joint sur 40 000 lignes, la macro s'exécute chez moi en 0,50 seconde

A+

 

[job75]

Comme le code est très rapide on peut le mettre dans une macro évènementielle de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sup$, deb As Range, dest As Range, tablo, ub&, i&, s, a(), n%, j%
sup = [B4] 'prénom à supprimer
Set deb = [D9]
If FilterMode Then ShowAllData 'si la feuille est filtrée
With Range(deb, Cells(Rows.Count, deb.Column).End(xlUp))
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ub = UBound(tablo)
    For i = 1 To UBound(tablo)
        s = Split(tablo(i, 1), vbLf)
        Erase a: n = 0
        For j = 0 To UBound(s)
            If s(j) <> "" And s(j) <> sup Then
                ReDim Preserve a(n)
                a(n) = s(j)
                n = n + 1
            End If
        Next j
        tablo(i, 1) = Join(a, vbLf)
    Next i
End With
Application.EnableEvents = False 'désactive les évènements
With [F9] '1ère cellule de destination, à adapter
    .Resize(ub) = tablo
    .Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

 

[Webperegrino]

Le Forum,

Bonjour Bsalv,

Autant pour moi, j’ai utilisé le Timer de Cousinhub, c’est mieux, et votre proposition affiche 0,0625 comme temps d’exécution ! C’est donc parfait.
(Rectif ci-joint)

Bonjour Cousinhub,
(2ème rectif ci-joint)
Un essai de votre solution sur mon OFFICE 16 : 0,3007 au premier essai et 0,2421 au second : époustouflant !
Sur un Mac de l’association (avec Office LTSC) : le temps d’exécution donne 0,136 !

Pouvez-vous jeter un coup d’œil dans les lignes de codes : j’ai une proposition-interrogation à votre intention.
Je ne vous dérange plus pas la suite ! (accéder à la modification de ‘Final’ en transformant en $D$9 : $D$50). Chez moi, modification possible de Base et Exclu mais pas Final dans « Formules · Gestion des noms : · Final’.)
Mon objectif est que, selon le contenu du pavé D9 : D50 votre macro fonctionne sans utiliser les pavés de la colonne G et de la colonne E.
Webperegrino

 

[Webperegrino]

Le Forum,
Oh ! Bonjour Job75.
Merci de votre intervention : j'étudie cela cet après-midi.
En effet, toute une série de calculs préparatoires donne un résultat de données dans G9 : G50.
Le traitement ne doit donc se faire que sur ce qui apparaît dans ce pavé G9 : G 50 dans la feuille.
Cordialement,
Webperegrino

 

[Webperegrino]

Le Forum,
Je suis enchanté par ces discussions.
Me voilà comblé par toutes ces propositions.
Je viens de vérifier : Job75, j'ai l'honneur de vous féliciter ! Vous grimpez aussi sur le podium pour recevoir la Médaille d'Or et d'Excellence !
C'est grandiose : quelle réactivité, vos lignes de codes !
Je me suis permis d'apporter une simplification car tout se traitera dans le pavé G9 : G50, dans mon vrai et lourd fichier d'application.
Un grand et cordial merci à vous tous.
Vous me sauvez vraiment dans ma gestion du temps d'attribution de postes pour plus de 90 bénévoles avec les répétition de calculs.
Meric encore,

 

[bsalv]

le chronomètre n'est pas adapté à la vitesse de la macro 😎
je l'ai collé dans la colonne E au lieu de D, donc modifier 2 en 3 >>> .Offset(, -3).Value = arr

 

[Webperegrino]

Le Forum,
Bsalv, j'aime la proposition #21.
En voici une simplification comme dans le fichier de Job75.
Le meilleur temps obtenu affiche 0,004
Maintenant, me voici avec l'embarras du choix de Vba
Merci
Webperegrino