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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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

Dernière édition:
Trier par date Trier par votes
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
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
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
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

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
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
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

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

J
  • Question Question
Microsoft 365 VBA transformer une formule au format texte en formule dans excel
Réponses
2
Affichages
59
jujulili
J
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
171
crocrocro
C
F
  • Résolu(e)
XL 2010 Macro : Remplissage de texte sous conditions
Réponses
11
Affichages
278
FLG
F
S
  • Résolu(e)
Microsoft 365 Mailing mise en forme HTML : revenir à la ligne automatique si trop de texte saisie
2
Réponses
17
Affichages
202
spike29
S
V
  • Question Question
Autres Pseudo_Calendrier_8s
Réponses
0
Affichages
289
VIARD
V
mjuju
  • Question 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
Eric 888
  • Résolu(e)
Microsoft 365 comment "ralentir" une macro
Réponses
9
Affichages
174
Eric 888
Eric 888
N
  • Question Question
Microsoft 365 Lien hypertexte supérieur à 255 carctères - Sans VBA
Réponses
5
Affichages
1 K
job75
job75
M
  • Question Question
Microsoft 365 Mise en forme lien hypertexte dans Useform
Réponses
2
Affichages
575
marie3107
M
cathodique
  • Question Question
XL 2010 Comptage Complexe
2 3
Réponses
40
Affichages
2 K
dysorthographie
dysorthographie
patricktoulon
  • Résolu(e)
Autres toutes versions tester le scrool avec la roulette sans passer par un hooking en addressof
31 32 33
Réponses
490
Affichages
4 K
Dudu2
Dudu2
patricktoulon
  • Question Question
Autres toutes versions tester le scrool avec la roulette sans passer par un hooking en addressof
Réponses
2
Affichages
53
patricktoulon
patricktoulon
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
893
firecarl
F
chris6999
  • Question Question
Microsoft 365 Boucle VB pour supprimer les caractères spéciaux et numériques d'une chaîne
Réponses
5
Affichages
440
patricktoulon
patricktoulon
S
  • Question Question
XL 2013 recherche intuitif semi automatique dans Combobox (trié et avec valeur unique) inseré en UserForm VBA
2
Réponses
18
Affichages
1 K
Sghaier Chafaa
S
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
731
laurent950
laurent950
R
  • Question Question
Microsoft 365 problème incompatibilité de type 13 sur macro "couper - coller"
Réponses
6
Affichages
357
rh.finances
R
B
  • Question Question
XL 2016 Macro pour identifier un texte dans un tableau et appliquer une modification sur une cellule sur la même ligne
Réponses
5
Affichages
522
ChTi160
ChTi160
C
  • Résolu(e)
XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop
Réponses
2
Affichages
368
crocrocro
C
C
  • Résolu(e)
XL 2021 Macro pour mise en page
Réponses
11
Affichages
568
candido57
C
Retour