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

 

[cathodique]

Bonjour,

Si j'ai bien compris la demande. Code à tester. Affecter macro "AppliquerNettoyage" au bouton ou à
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Function NettoyerTexteComplet(ByVal Texte As String, ws As Worksheet) As String
    Dim i As Integer
    Dim CharCode As Integer
    Dim TexteNettoye As String
    
    TexteNettoye = Texte
    
    ' Remplacer le mot à supprimer par un espace unique
    TexteNettoye = Replace(TexteNettoye, ws.Range("B4").Value, " ")

    ' Remplacer les caractères spéciaux par des espaces
    TexteNettoye = Replace(TexteNettoye, vbLf, " ")
    TexteNettoye = Replace(TexteNettoye, vbCr, " ")
    TexteNettoye = Replace(TexteNettoye, vbTab, " ")

    ' Supprimer les caractères non imprimables restants
    For i = 1 To Len(TexteNettoye)
        CharCode = Asc(Mid(TexteNettoye, i, 1))
        If CharCode >= 32 And CharCode <> 127 Then
            NettoyerTexteComplet = NettoyerTexteComplet & Mid(TexteNettoye, i, 1)
        End If
    Next i
    
    ' Éliminer les espaces multiples tout en conservant les séparations naturelles
    NettoyerTexteComplet = Trim(Replace(NettoyerTexteComplet, "  ", " "))

End Function

Sub AppliquerNettoyage()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    Set ws = ThisWorkbook.Sheets("Feuil1") ' À remplacer par le vrai nom
    Set rng = ws.Range("D9:D32")
    
    ' Appliquer le nettoyage à chaque cellule de la plage
    For Each cell In rng
        cell.Offset(0, 5).Value = NettoyerTexteComplet(cell.Value, ws)
    Next cell
End Sub

 

[bsalv]

quoi faire Jean-Pierre ou Jeanne dans cette cellule ?

 

[bsalv]

Sub Jean()
For Each c In Range("D9😀33").Cells
'choisir un des 2 lignes sp=....
sp = Split(Replace(vbLf & c.Value & vbLf, vbLf & Range("B3").Value & vbLf, vbLf), vbLf) 'ignorer Jean-pierre, Jeanne, etc
'sp = Split(Replace(c.Value, Range("B4").Value, ""), vbLf)
s = ""
For i = 0 To UBound(sp)
If Len(sp(i)) > 0 Then s = s & vbLf & sp(i)
Next
c.Offset(, 6).Value = Mid(s, 2)
Next
End Sub

 

[patricktoulon]

Bonjour
la base de ce genre de travail est de normaliser
c'est a dire ramener toute les possibilités a qu'une seule
pour cela on remplace une première fois tout les saut de ligne par un espace (on a donc normaliser les texte de la même manière)
et apres on remet le text en faisant un replace de l'espace sur la globalité avec application trim(qui reduit a un seul espace consécutif
terminé
ici dans l'event d'un bouton
on peut le faire dans un autre event tel que le change dans cette plage bien precise

Private Sub CommandButton1_Click()
    Dim cel As Range, Plage As Range
    Dim Mot As String
    Set Plage = Range("D9:D33")
    Mot = [B4] 'mot à supprimer
    Application.ScreenUpdating = False
     For Each cel In Plage
        cel.Value = Replace(Replace(cel.Value, Chr(10), " "), "Jean", " ")'normalisation et remplacement  du mot"Jean"
        cel.Value = Replace(Application.Trim(cel.Value), " ", Chr(10))' reduction des espace consécutifs et remplacement des espaces restants par un saut de ligne
    Next
    Application.ScreenUpdating = True
    [A1].Select
End Sub

 

[patricktoulon]

maintenant ca risque de se compliquer pour les noms composés avec "Jean"

 

[Webperegrino]

Le Forum,
Ça avance à grande vitesse,
J'ai appliqué les deux solutions de Cathodique puis de Bsalv.
Bsalv donne de très bons résultats (avant d'appuyer sur les boutons respectifs, recopier le contenu de G9 : G12 dans D9 puis cliquer sur l'un des boutons.
La solution de Cathodique fait disparaître tous les Vblf
Merci à vous deux,
Webperegrino

 

[patricktoulon]

a ben non finalement pas si compliqué que ça
voila les prénoms composé sont sauvegardé

Private Sub CommandButton1_Click()
    Dim cel As Range, Plage As Range
    Dim Mot As String
    Set Plage = Range("D9:D33")
    Mot = [B4] 'mot à supprimer
    Application.ScreenUpdating = False
     For Each cel In Plage
        cel.Value = Replace(Replace(" " & cel.Value & " ", Chr(10), " "), " Jean ", "  ")
        cel.Value = Replace(Application.Trim(cel.Value), " ", Chr(10))
    Next
    Application.ScreenUpdating = True
    [A1].Select
End Sub

 

[patricktoulon]

click sur le bouton patricktoulon

 

[Webperegrino]

Le Forum,
Patrick, Bsalv,
Vous êtes tous les deux sur le Podium, en première place !
Quant à Cathodique vous recevez du bronze car certains retours disparaissent malheureusement, et Pierre et Jeanne sont martyrisés dans J12...
Je vais voir maintenant laquelle des deux premières est la plus rapide...
Merci beaucoup à vous trois.
Il faudrait pouvoir vous attribuer, à tous les deux, le marquage comme solution trouvée (ligne verte et marquage comme solution) ; désolé pour Patricktoulon...
Bonne soirée,
Cordialement,
Webperegrino

 

[Webperegrino]

Le Forum,
Médaille d'Or : Bsalv avec 6,27 secondes !
Médaille d'Argent : Patricktoulon : avec 9,36 secondes !
... sur mon Excel 2019 ; que demander de mieux !
Bravo à tous les deux, même pas le temps de faire une inspiration avec vos deux macros....
Webperegrino

 

[Cousinhub]

Bonsoir,
Juste pour le fun
Les données en "D9 : D38"
un tout petit peu plus que 3 secondes...
Bonne soirée, et bonne semaine
Pour les personnes intéressées par Power Query :

let
    Source = Excel.CurrentWorkbook(){[Name="Base"]}[Content],
    Exclus = Excel.CurrentWorkbook(){[Name="Exclu"]}[Content][Column1],
    Transform = Table.TransformColumns(Source, {{"Column1", each Text.Combine(List.RemoveItems(Text.Split(_,"#(lf)"),Exclus),"#(lf)")}})
in
    Transform

 

[Webperegrino]

Le Forum,
Wouah ! 3 secondes !
J'étudie cela demain, mais ça risque de coincer avec mon Excel 2019.
J'étudierai aussi la proposition de Cathodique car en y ajoutant la ligne de Bsalv ...

 sp = Split(Replace(vbLf & c.Value & vbLf, vbLf & Range("B3").Value & vbLf, vbLf), vbLf)

... ça devrait aussi apporter plus de 'résonance' avec ce que je voulais au final.
Merci encore, d'ici à ce qu'il y ait deux médailles d'or à préparer... concurrence entre Bsalv et Cousinhub (ici, le Brestois de naissance remercie le Brestois).
Vous me comblez tous les quatre, bravo.
Webperegrino

 

[cathodique]

Bonjour,

J'étudierai aussi la proposition de Cathodique car en y ajoutant la ligne de Bsalv ...

Personnellement, j'ai répondu d'après ce que j'ai compris: "Retirer la chaîne saisie dans la cellule" et tous les caractères spéciaux tel que "vblf" ...

C'est ton titre qui m'a induit en erreur ou bien, j'ai lu en oblique ta demande.

Bonne journée.

 

[bsalv]

en ajoutant le "screenupdating" le temps est combien ?
Parce que 6 secondes, c'est beaucoup, c'était combien de cellules ?
Contournement = si le nombre de cellules est assez grand, utiliser une matrice et tout faire en mémoire

Sub Jean()
     Application.ScreenUpdating = False
     For Each c In Range("D9??33").Cells
          'choisir un des 2 lignes sp=....
          sp = Split(Replace(vbLf & c.Value & vbLf, vbLf & Range("B3").Value & vbLf, vbLf), vbLf)     'ignorer Jean-pierre, Jeanne, etc
          'sp = Split(Replace(c.Value, Range("B4").Value, ""), vbLf)
          s = ""
          For i = 0 To UBound(sp)
               If Len(sp(i)) > 0 Then s = s & vbLf & sp(i)
          Next
          c.Offset(, 6).Value = Mid(s, 2)
     Next
End Sub