Microsoft 365 VBA supprimer toutes les parenthèses sauf les 2 dernieres

raf26 · 1 Juin 2023

Bonjour,

J'aurais besoin de votre aide pour une macro

Je reçois des lignes de livraisons, avec aléatoirement des mots entre parenthèses et toujours la variété en dernier entre parenthèses.

Ces lignes sont collés par macro dans un tableau et ensuite une formule m'extrait la variété entre parenthèses.

Seulement si d'autres parenthèses sont présentes avant celles de la variété ma formule échoue.

Je chercher donc à intégré à ma macro de collage la "formule" qui me supprime toutes les parenthèses sauf les 2 dernières.

J'ai bien essayé avec l'enregistreur de macro et la fonction remplacer mais cela ne me permets pas de sélectionner certaines parenthèses.

Exemple
ligne reçue POMME (Espagne) CAL 3 (golden)
ligne collée après traitement macro POMME Espagne CAL 3 (golden)

J'espère avoir été assez claire dans ma demande.

Je vous joins un fichier exemple.

Merci d'avance

Cordialement

Dranreb · 1 Juin 2023

Bonsoir.
Cette fonction perso renvoie les résultats attendus :

VB:

Function SsParthMilieu(ByVal Z As String) As String
   Dim TJn() As String, P As Integer
   TJn = Split(Z, "(")
   For P = 0 To UBound(TJn) - 1
      TJn(P) = Replace(TJn(P), ")", "")
      Next P
   TJn(P) = "(" & TJn(P)
   SsParthMilieu = Join(TJn, "")
   End Function

… sauf pour POMME (France)(PACA) (pink lady)
qui donne POMME FrancePACA (pink lady)
Peut se réparer si nécessaire en changeant la 3ème instruction :

Code:

   TJn = Split(Replace(Z, ")(", ") ("), "(")

fanch55 · 1 Juin 2023

Bonsoir,
Même combat que Dranreb sauf renvoi différent pour les pink lady :

VB:

Function Blabla(Cel As Range)
    T = Split(Cel, "(")
    For I = 0 To UBound(T) - 1
        T(I) = Replace(T(I), ")", " ")
    Next
    T(UBound(T)) = "(" & T(UBound(T))
    Blabla = Join(T)
End Function

Appel fonction dans cellule :

raf26 · 1 Juin 2023

Bonjour Dranreb et fanch55

Merci pour vos retours hyper rapide !

Je vais tester vos 2 solutions, toutefois une question, comment insérer votre macro dans la mienne (ci-dessous) ?

VB:

Sheets("mononglet").Select
    Range("DA38").Select
    ActiveSheet.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:= _
                             False
    Range("DA38").Select
End Sub

J'ai un bouton qui me déclenche cette macro de collage

Dranreb · 1 Juin 2023

Ben ajoutez

VB:

Range("DA38").Value = SsParthMilieu(Range("DA38").Value)

sylvanu · 1 Juin 2023

Bonsoir Raf, Dranreb, Fanch,
Ou encore avec ceci :

VB:

Function Nettoie(C$)
    Pos = InStrRev(C, "(")
    C1 = Replace(Replace(Mid(C, 1, Pos), "(", ""), ")", "")
    Nettoie = C1 & " " & Mid(C, Pos)
End Function

et dans votre macro (perfectible ) on doit pouvoir faire :

Code:

Sub essai()
    Sheets("mononglet").Select
    Range("DA38").Select
    ActiveSheet.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
    Range("DA38").Select
    Range("DA38") = Nettoie(Range("DA38"))
End Sub

raf26 · 1 Juin 2023

Bonsoir Sylvanu,

VB:

votre macro (perfectible )

C'est l'enregistreur de macro 🙂

raf26 · 1 Juin 2023

Je teste vos solutions demain matin et vous redit.

Encore merci à vous 3 pour la rapidité de vos retours, vous êtes impressionnants.

Staple1600 · 1 Juin 2023

Bonjour

Puisque le préfixe indique Microsoft 365
Une formule (un peu longue) qui semble OK

=SUBSTITUE(SUBSTITUE(TEXTE.AVANT(A1;"(";NBCAR(A1)-NBCAR(SUBSTITUE(A1;"(";"")));")";"");"(";"")&"("&TEXTE.APRES(A1;"(";NBCAR(A1)-NBCAR(SUBSTITUE(A1;"(";"")))

Staple1600 · 1 Juin 2023

Re

Toujours grâce à 365, on peut raccourcir la formule en
=SUBSTITUE(SUBSTITUE(PMOT(A1);"(";"");")";"")&DMOT(A1)
(en utilisant la fonction LAMBDA)

DMOT	=LAMBDA(chaine;"("&FILTRE.XML("<t><s>" & SUBSTITUE(chaine;"(";"</s><s>") &"</s></t>"; "//s[last()]"))
PMOT	=LAMBDA(chaine;GAUCHE(chaine;CHERCHE(DMOT(chaine);chaine)-1))

NB: DMOT et PMOT sont donc des formules nommées qui apparaissent dans le gestionnaire de noms

mapomme · 1 Juin 2023

Bonsoir à tous 😉 ,

Une autre petite fonction personnalisée qui fait le boulot :

VB:

Function DernierTerme$(ByVal x$)
Dim n&, y$, z$
   n = InStrRev(x, "("): If n = 0 Then Exit Function
   y = Left(x, n - 1): y = Replace(Replace(y, "(", "  "), ")", "  "): z = " " & Mid(x, n)
   DernierTerme = Application.Trim(y & z)
End Function

raf26 · 2 Juin 2023

sylvanu à dit:

Bonsoir Raf, Dranreb, Fanch,
Ou encore avec ceci :

VB:

Function Nettoie(C$)
    Pos = InStrRev(C, "(")
    C1 = Replace(Replace(Mid(C, 1, Pos), "(", ""), ")", "")
    Nettoie = C1 & " " & Mid(C, Pos)
End Function

et dans votre macro (perfectible ) on doit pouvoir faire :

Code:

Sub essai()
    Sheets("mononglet").Select
    Range("DA38").Select
    ActiveSheet.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
    Range("DA38").Select
    Range("DA38") = Nettoie(Range("DA38"))
End Sub

Bonjour Sylvanu,

Si je souhaite appliquer votre macro à ma plage qui est collée

Ex de : B14 à B180, quelles références je dois spécifier ?

J'ai essayé

VB:

Range("B14:B180") = Nettoie(Range("B14:B180"))

mais cela ne marche pas

sylvanu · 2 Juin 2023

raf26 à dit:
Range("B14:B180") = Nettoie(Range("B14:B180"))

Ce serait trop simple. 🙂
Une possibilité :

VB:

For L = 14 To 180
    Cells(L, "B") = Nettoie(Cells(L, "B"))
Next L

ou si la plage est grande, pour être plus rapide, ou peut être est ce plus simple :

Code:

Sub Nettoie(Plage)
tablo = Range(Plage)
For i = 1 To UBound(tablo)
    C = tablo(i, 1)
    Pos = InStrRev(C, "(")
    C1 = Replace(Replace(Mid(C, 1, Pos), "(", ""), ")", "")
    If tablo(i, 1) <> "" Then tablo(i, 1) = C1 & " " & Mid(C, Pos)
Next i
Range(Plage) = tablo
End Sub

et l'appel se fait par :

Code:

Sub test()
Nettoie ("B14:B180")
End Sub

raf26 · 2 Juin 2023

mapomme à dit:
Bonsoir à tous 😉 ,

Une autre petite fonction personnalisée qui fait le boulot :

VB:

Function DernierTerme$(ByVal x$) Dim n&, y$, z$ n = InStrRev(x, "("): If n = 0 Then Exit Function y = Left(x, n - 1): y = Replace(Replace(y, "(", " "), ")", " "): z = " " & Mid(x, n) DernierTerme = Application.Trim(y & z) End Function

Bonjour mapomme,

Je voudrais tester ta fonction, merci de ton retour.

Je la copie dans un nouveau module, mais comment l'appeler dans ma macro de collage ?

VB:

Sheets("mononglet").Select
    Range("DA38").Select
    ActiveSheet.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:= _
                             False
    Range("DA38").Select
End Sub

fanch55 · 2 Juin 2023

Bonjour,
Le pasteSpecial indiqué est spécifique à un copy externe à Excel :
Un exemple avec votre extrait de code :

VB:

Option Explicit
' -----------------------------------------------------------------------------------------
Sub Coller_Ext()
Dim Cel As Range

' on suppose que le copier a été effectué sur une appli externe

Sheets("mononglet").Select
    Range("DA38").Select
    ActiveSheet.PasteSpecial Format:="Texte"
    For Each Cel In Selection.Cells
        Cel = Blabla(Cel)
    Next
End Sub
' -----------------------------------------------------------------------------------------
Sub Coller_Range()
Dim Cel As Range

' on suppose que le copier a été effectué sur un range de cellules
'      Sheets("Feuil1").Range("E8:E11").Copy

Sheets("mononglet").Select
    Range("DA38").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    For Each Cel In Selection.Cells
        Cel = Blabla(Cel)
    Next
End Sub
' -----------------------------------------------------------------------------------------
Function Blabla(Cel As Range)
Dim T, I
    T = Split(Cel, "(")
    For I = 0 To UBound(T) - 1
        T(I) = Replace(T(I), ")", " ")
    Next
    T(UBound(T)) = "(" & T(UBound(T))
    Blabla = Join(T)
End Function

Microsoft 365 VBA supprimer toutes les parenthèses sauf les 2 dernieres

raf26

XLDnaute Occasionnel

Pièces jointes

Dranreb

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

Dranreb

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Pièces jointes

raf26

XLDnaute Occasionnel

raf26

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

Discussions similaires

Microsoft 365 VBA supprimer toutes les parenthèses sauf les 2 dernieres

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency