XL 2019 Macro Privat Sub : Mettre texte en italique avant <i/> et supprimer ensuite <i/> en gardant texte en italique

lusert

XLDnaute Junior
Bonjour cher réseau,

J'avais créé il y a 1 an un sujet sur une liste déroulante de saisie, basée sur une combobox et des codes privat sub intégré à la feuille de saisie ou se trouve la combobox (voir fichier en exemple) aujourd'hui toujours sur ce même fichier je cherche à l'améliorer, réduire les phrases macros au plus simple, rendre la macro plus rapide et opérationnelle ^^

J'ai fusionner à ma combobox une saisie gardant la mise en forme du texte de la BD, la structure de la macro est correcte selon vous ?

Le point important que je n'arrive vraiment pas à débloquer et la mise en italique de mon texte situé avant le symbole <i/> ou de mettre sans italique le texte situé après ce même symbole.
Quand je fais une de ces étapes ça fonctionne mais quand un code macro supprime <i/> alors le texte reste en italique ou reste sans italique (car avant j'ai un code qui met tout en italique ou sans italique selon le choix True et false)
ex :
<i>blabla blabla <i/> blabla blabla
avec macro italique = <i>blabla blabla <i/> blabla blabla ou <i>blabla blabla <i/> blabla blabla
quand je supprime <i/> rendu = <i>blabla blabla <i/> blabla blabla

Je vous remercie d'avance pour votre aide :)
Et en espérant que cette manipe est faisable ^^

A bientôt
Thomas

Ps : une question bête du à mon ignorance et ma recherche internet non fructueuse, peut-on depuis ma combobox avoir une plage de saisie sur deux colonne, actuellement ma combobox se base sur les cellules de la Colonne B et j'aimerais faire ma saisie intuitive depuis les cellules de la colonne B à D
 

Pièces jointes

  • test supprimersymbole.xlsm
    582.9 KB · Affichages: 19
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir lusert,

Votre code c'est votre affaire, si vous avez un problème créez une discussion en l'exposant clairement.

Pour répondre au problème posé ici exécutez cette macro :
VB:
Sub Italique()
Dim balise1$, balise2$, L$, c As Range, x$, i%, j%, k%
balise1 = "<i>": balise2 = "</i>": L = Len(balise1)
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
For Each c In ActiveSheet.UsedRange 'la feuille active est traitée
    x = CStr(c)
    For i = 1 To Len(x)
        If Mid(x, i, L) = balise1 Then
            j = InStr(i + L, x, balise2)
            k = InStr(i + L, x, balise1)
            If k = 0 Then k = 32767
            If j And j <= k Then
                c.Characters(i + L, j - i - L).Font.Italic = True
                i = j
            End If
        End If
Next i, c
End Sub
A+
 

job75

XLDnaute Barbatruc
Bonjour lusert, le forum,

Voici la macro avec mise en italique après l'effacement des 2 balises :
VB:
Sub Italique()
Dim balise1$, balise2$, L1$, L2$, a$(), c As Range, n&, x$, sup%, i%, j%, k%, ss, s
balise1 = "<i>": balise2 = "</i>": L1 = Len(balise1): L2 = Len(balise2)
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
With ActiveSheet.UsedRange 'la feuille active est traitée
    '---tableau des bornes---
    ReDim a(1 To .Count)
    For Each c In .Cells
        n = n + 1
        x = CStr(c)
        sup = 0
        For i = 1 To Len(x)
            If Mid(x, i, L1) = balise1 Then
                j = InStr(i + L1, x, balise2)
                k = InStr(i + L1, x, balise1)
                If k = 0 Then k = 32767
                If j And j <= k Then
                    sup = sup + L1
                    a(n) = a(n) & " " & i - sup + L1 & "," & j - i - L1
                    sup = sup + L2
                    i = j + L2 - 1
                End If
            End If
    Next i, c
    '---effacement des 2 balises---
    .Replace balise1, "", xlPart
    .Replace balise2, ""
    '---application des formats---
    n = 0
    For Each c In .Cells
        n = n + 1
        If a(n) <> "" Then
            ss = Split(a(n))
            For i = 1 To UBound(ss)
                s = Split(ss(i), ",")
                c.Characters(s(0), s(1)).Font.Italic = True
            Next i
        End If
    Next c
End With
End Sub
J'ai testé après avoir entré ce texte dans 100 000 cellules :
<i>Potamogeton friesii</i> Rupr., 1861 ou <i>Potamogeton friesii</i> Rupr., 1862
La macro s'exécute chez moi en 18 secondes.

A+
 

lusert

XLDnaute Junior
Bonsoir lusert,

Votre code c'est votre affaire, si vous avez un problème créez une discussion en l'exposant clairement.

Pour répondre au problème posé ici exécutez cette macro :
VB:
Sub Italique()
Dim balise1$, balise2$, L$, c As Range, x$, i%, j%, k%
balise1 = "<i>": balise2 = "</i>": L = Len(balise1)
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
For Each c In ActiveSheet.UsedRange 'la feuille active est traitée
    x = CStr(c)
    For i = 1 To Len(x)
        If Mid(x, i, L) = balise1 Then
            j = InStr(i + L, x, balise2)
            k = InStr(i + L, x, balise1)
            If k = 0 Then k = 32767
            If j And j <= k Then
                c.Characters(i + L, j - i - L).Font.Italic = True
                i = j
            End If
        End If
Next i, c
End Sub
A+
Je vous remercie pour m'avoir répondu aussi vite, je vais voir ce que donne votre code :)
 

lusert

XLDnaute Junior
Bonjour lusert, le forum,

Voici la macro avec mise en italique après l'effacement des 2 balises :
VB:
Sub Italique()
Dim balise1$, balise2$, L1$, L2$, a$(), c As Range, n&, x$, sup%, i%, j%, k%, ss, s
balise1 = "<i>": balise2 = "</i>": L1 = Len(balise1): L2 = Len(balise2)
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
With ActiveSheet.UsedRange 'la feuille active est traitée
    '---tableau des bornes---
    ReDim a(1 To .Count)
    For Each c In .Cells
        n = n + 1
        x = CStr(c)
        sup = 0
        For i = 1 To Len(x)
            If Mid(x, i, L1) = balise1 Then
                j = InStr(i + L1, x, balise2)
                k = InStr(i + L1, x, balise1)
                If k = 0 Then k = 32767
                If j And j <= k Then
                    sup = sup + L1
                    a(n) = a(n) & " " & i - sup + L1 & "," & j - i - L1
                    sup = sup + L2
                    i = j + L2 - 1
                End If
            End If
    Next i, c
    '---effacement des 2 balises---
    .Replace balise1, "", xlPart
    .Replace balise2, ""
    '---application des formats---
    n = 0
    For Each c In .Cells
        n = n + 1
        If a(n) <> "" Then
            ss = Split(a(n))
            For i = 1 To UBound(ss)
                s = Split(ss(i), ",")
                c.Characters(s(0), s(1)).Font.Italic = True
            Next i
        End If
    Next c
End With
End Sub
J'ai testé après avoir entré ce texte dans 100 000 cellules :

La macro s'exécute chez moi en 18 secondes.

A+
Je vous remercie pour votre réponse, je vais tester votre code :)
 

lusert

XLDnaute Junior

Bonjour job75,​

J'ai ajouté vos deux différentes macros à mon fichier. J'ai oublié de préciser dans ma description que je bosse sur des codes Privat Sub basé sur une combobox ^^ Mince...

Alors pour le retour d'expérience, la première macro fonctionne que sur la première cellule comportant le symbole </i> et votre deuxième macro elle prend en compte toutes les lignes :) par contre j'ai tenté d'inverser les valeurs True/False de votre code italique mais ce la laisse tout le texte en italique ou tout le texte sans italique, j'ai l'impression que dès que le symbole </i> est supprimé cela enlève la partie du texte à garder en italique et l'autre sans italique ?
Je vous remercie déjà pour cette première fouille :)
 

lusert

XLDnaute Junior
La 1ère et la 2ème macro traitent touts deux toutes les cellules du UsedRange.

Les textes entre les 2 balises sont mis en italique, pas les autres.

Vous perdrez votre temps si vous essayez de modifier les codes.
En faite, j'avais dans ma macro initiale un code italique qui empêche le bon fonctionnement de votre macro j'ai testé sur un document vierge et ça fonctionne, Super :) merci beaucoup pour le code :)
Maintenant je n'ai plus qu'à adapter le code sub en code privat sub pour ne pas me retrouver avec pleins de boutons à cliquer
 

lusert

XLDnaute Junior
Rebonjour job75, le réseau,
Ci-joint mon document simplifié !
J'ai pu combiner votre code avec mon second code qui termine la mise en forme du texte.
J'appelle les deux macro depuis un commonbouton (private sub) ou d'un bouton basé sur le code appel (sub). Le petit soucis c'est que ce code n'est pas lié au private sub de ma combobox ainsi si le code est intégré par Private Sub CommandButton1_Click() alors je perds la mise en forme dès une nouvelle saisie et si j'utilise Sub Appel() je dois attendre de saisir mes 10 ou 120 espèces sinon elle supprime la mise en forme des saisies mise en forme après un second clic (saisie puis bonne mise en forme puis deuxième saisie bonne mise en forme mais ancienne saisie perd la mise en forme).
exemple brut du code ci-dessous ;)

VB:
Sub Italique()
Dim balise1$, balise2$, L1$, L2$, a$(), c As Range, n&, x$, sup%, i%, j%, k%, ss, s
balise1 = "<i>": balise2 = "</i>": L1 = Len(balise1): L2 = Len(balise2)
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
With ActiveSheet.UsedRange 'la feuille active est traitée
    '---tableau des bornes---
    ReDim a(1 To .Count)
    For Each c In .Cells
        n = n + 1
        x = CStr(c)
        sup = 0
        For i = 1 To Len(x)
            If Mid(x, i, L1) = balise1 Then
                j = InStr(i + L1, x, balise2)
                k = InStr(i + L1, x, balise1)
                If k = 0 Then k = 32767
                If j And j <= k Then
                    sup = sup + L1
                    a(n) = a(n) & " " & i - sup + L1 & "," & j - i - L1
                    sup = sup + L2
                    i = j + L2 - 1
                End If
            End If
    Next i, c
    '---effacement des 2 balises---
    .Replace balise1, "", xlPart
    .Replace balise2, ""
    '---application des formats---
    n = 0
    For Each c In .Cells
        n = n + 1
        If a(n) <> "" Then
            ss = Split(a(n))
            For i = 1 To UBound(ss)
                s = Split(ss(i), ",")
                c.Characters(s(0), s(1)).Font.Italic = True
            Next i
        End If
    Next c
End With
End Sub
Sub Sansi()
  mot = " subsp. "
  For Each c In Range("B23:B200" & [B65000].End(xlUp).Row)
   P = InStr(UCase(c), UCase(mot))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot)).Font.Italic = False
  Next c
  mot2 = " var. "
  For Each c In Range("B23:B200" & [B65000].End(xlUp).Row)
   P = InStr(UCase(c), UCase(mot2))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot2)).Font.Italic = False
  Next c
  mot3 = " sp. "
  For Each c In Range("B23:B200" & [B65000].End(xlUp).Row)
   P = InStr(UCase(c), UCase(mot3))
   If P > 0 Then c.Characters(Start:=P, Length:=Len(mot3)).Font.Italic = False
  Next c
End Sub
Sub Appel()
Call Italique
Call Sansi
End Sub

ou
Private Sub CommandButton1_Click()
Italique
Sansi
End Sub

Je pense que c'est ce code qui pose problème :
Application.ScreenUpdating = False
Cells.Font.Italic = False 'RAZ
With ActiveSheet.UsedRange 'la feuille active est traitée

Il ne fait pas référence à la plage de saisie que j'utilise :
"If Not Intersect(Target, [B22:B180]) Is Nothing" ou "For Each c In Range("B23:B200" & [B65000].End(xlUp).Row)"

et je n'arrive pas à changer cela ni à référencer ma combobox "Me.ComboBox1 = Target" (enfin je pense que c'est ce code là à intégrer ???)

Merci d'avance pour vos avis
Thomas, un naturaliste qui essaie de simplifier la saisie après le terrain
 

Pièces jointes

  • FICHE_de_RELEVE_test.xlsm
    844.9 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T