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

L

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:
Trier par date Trier par votes
job75

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+
 
Vote positif 0 Vote négatif
job75

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
Cliquez pour agrandir...
La macro s'exécute chez moi en 18 secondes.

A+
 
Vote positif 0 Vote négatif
L

lusert

XLDnaute Junior
job75 à dit:
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+
Cliquez pour agrandir...
Je vous remercie pour m'avoir répondu aussi vite, je vais voir ce que donne votre code :)
 
Vote positif 0 Vote négatif
L

lusert

XLDnaute Junior
job75 à dit:
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+
Cliquez pour agrandir...
Je vous remercie pour votre réponse, je vais tester votre code :)
 
Vote positif 0 Vote négatif
L

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 :)
 
Vote positif 0 Vote négatif
L

lusert

XLDnaute Junior
job75 à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
L

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
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2010 Macro : Remplissage de texte sous conditions
Réponses
11
Affichages
246
FLG
F
N
  • Question
Microsoft 365 Lien hypertexte supérieur à 255 carctères - Sans VBA
Réponses
5
Affichages
1 K
job75
job75
V
  • Question
Autres Pseudo_Calendrier_8s
Réponses
0
Affichages
255
VIARD
V
M
  • Question
Microsoft 365 Mise en forme lien hypertexte dans Useform
Réponses
2
Affichages
557
marie3107
M
F
  • Résolu(e)
Microsoft 365 Comment enregistrer chaque ligne en tant que fichier texte dans Excel?
2
Réponses
24
Affichages
708
TooFatBoy
TooFatBoy
Dudu2
  • Résolu(e)
XL 2016 VBA - Calcul des hauteur et largeur des Headings (pour les forts en thème)
2
Réponses
23
Affichages
560
Dudu2
Dudu2
p'tit vieux
  • Question
XL 2021 VBA: Extraction des paramètres d'une formule (texte)
2
Réponses
28
Affichages
706
p'tit vieux
p'tit vieux
mjuju
  • Question
Microsoft 365 Déplacer cellules en gardant mise en forme source et cible (via VBA)
2 3
Réponses
34
Affichages
1 K
TooFatBoy
TooFatBoy
A
  • Résolu(e)
Microsoft 365 Enregistrer copie d'un fichier avec pour nom le contenu d'une cellule excel (macro)
2
Réponses
15
Affichages
790
firecarl
F
Bernard38
  • Résolu(e)
Microsoft 365 VBA : formule Excel en variable
2
Réponses
24
Affichages
1 K
mapomme
mapomme

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 63 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki