Fonction Characters(debut, long).delete

Bonjour,

J'ai un problème insolvable, enfin, j'aimerais qu'il le soit. Mais comme je ne comprend pas du tout d'ou vient le souci, et bien je ne peux pas le résoudre.

Voila, j'utilise la procédure Characters(debut, longueur).delete pour effacer du texte spécifique (de couleur) dans une cellule.

Mais selon les cellules, ça ne marche pas toujours. Ca ne bug pas, ça passe sur le code (exécute ou pas ....) passe a la ligne suivante, mais le texte n'est pas supprimé. Dans ma feuille, j'ai des cellules ou cela fonctionne et d'autre ou ça ne fonctionne pas. Meme en collant les cellules ou ça n'a pas marché dans celles ou ça a marché, ça ne change rien .... je ne comprend vraiment pas pourquoi il ne veut pas m'effacer le texte.

HELP HELP HELP

On peut avoir un exemple ?

Genre un fichier Excel avec ta macro déjà où tu utilises ton Delete, puis les cellules avec celles qui fonctionnent et celles qui ne fonctionnent pas ?

On pourra faire le test comme ça :)

1 pièce(s) jointe(s)

Voila déjà le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Sub Mise_en_Forme()
'
' Supprime les caractère en rouge et met en noir les caractères en vert
'
 
Dim Debut As Integer
Dim Longueur As Integer
Dim LnCell As Integer
Dim Couleur As Integer
Dim Cellule As Range
 
Windows("RER_NG_II.2 - SdF version du 19-07-2013 sans protection.xls").Activate
Worksheets("Feuil1").Activate
'Application.ScreenUpdating = False
 
    For i = 11 To 11 '658               'Boucle sur toutes les lignes du fichier
    Set Cellule = Range("h" & i)    'Affecte l'adresse de la cellule à traiter à la variable Cellule
 
    LnCell = Len(Cellule)           'Calcul le nombre total de caractères de la cellule à traiter
    Debut = 1
    Longueur = 1
    MsgBox ("Traitement Ligne " & i)
    For j = 1 To LnCell                                             'Fonction qui recherche les codes de couleurs
 
        If Cellule.Characters(j, 1).Font.ColorIndex < -1 Then       'égal à -4105 déjà présents dans la cellule
            Cellule.Characters(j, 1).Font.ColorIndex = 1            'Corrige le code par le noir
            'MsgBox ("erreur couleur police cellule H" & i & " position " & j)
 
        End If
 
    Next j
 
    Do                              'Boucle qui permet de traiter tous les caractères de la cellule traitée
 
        If LnCell = 0 Then Exit Do  'Sort de la boucle pour les celulles vides
 
        While IsNumeric(Cellule.Characters(Debut, Longueur).Font.ColorIndex) And (Debut + Longueur) < LnCell + 2
            Longueur = Longueur + 1 'Boucle qui permet de connaitre la longeur de la chaine de caractères
                                    'de même couleur + 1 caractère (on sort de la boucle lorsque deux caractéres
                                    'consécutifs n'ont pas la même couleur)
        Wend
 
        If Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex > -1 Then  'Test pour discriminer la couleur -4105
            Couleur = Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex
        End If
 
    MsgBox (Cellule.Characters(Debut, Longueur - 1).Caption)
 
        Select Case Couleur
            Case 1                  'Couleur noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 10                 'Couleur Verte
                Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex = 1 'On met la police en noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 14                 'Autre couleur verte
                Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex = 1 'On met la police en noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 3                  'Couleur rouge
                If Cellule.Characters(Debut, 1).Text = " " Then         'Si le premier caractere est un espace, on le
                    Cellule.Characters(Debut, 1).Font.ColorIndex = 1    'met en couleur noire et on ne le supprime pas.
                    Cellule.Characters(Debut + 1, Longueur - 2).Delete  'Suppression du reste
                    Debut = Debut + 1                                       'Incrémentation compteur
                    LnCell = LnCell - Longueur + 2   'Modification de la longueur totale de la chaine à traiter
                Else
                    Cellule.Characters(Debut, Longueur - 1).Delete    'Si le premier caractère n'est pas un espace
                    LnCell = LnCell - Longueur + 1   'Modification de la longueur totale de la chaine à traiter                   'on supprime l'ensemble
                End If
 
        End Select
 
    Longueur = 1
 
    Loop While Debut < LnCell
 
    'Rows(i & ":" & i).EntireRow.AutoFit             'adapte la hauteur de la ligne en fonction du contenu de la cellule
 
    Next i
    'Columns("H:H").Select
    'With Selection
    '    .VerticalAlignment = xlTop
    '    .Orientation = 0
    '    .AddIndent = False
    '    .IndentLevel = 0
    '    .ShrinkToFit = False
    '    .ReadingOrder = xlContext
    '    .MergeCells = False
    'End With
   ' Application.ScreenUpdating = True
End Sub

C'est dans le cas du Case 3 après le Else que le Delete ne marche pas.

La pièce jointe attachée et le code pour ce fichier

La première cellule, la 11, ça marche pas, la 12, ça marche ....

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Sub Mise_en_Forme_2()
'
' Supprime les caractère en rouge et met en noir les caractères en vert
'
 
Dim Debut As Integer
Dim Longueur As Integer
Dim LnCell As Integer
Dim Couleur As Integer
Dim Cellule As Range
 
'Windows("Classeur1.xls").Activate
Worksheets("Feuil1").Activate
'Application.ScreenUpdating = False
 
    For i = 11 To 12 '658               'Boucle sur toutes les lignes du fichier
    Set Cellule = Range("c" & i)    'Affecte l'adresse de la cellule à traiter à la variable Cellule
 
    LnCell = Len(Cellule)           'Calcul le nombre total de caractères de la cellule à traiter
    Debut = 1
    Longueur = 1
    MsgBox ("Traitement Ligne " & i)
    For j = 1 To LnCell                                             'Fonction qui recherche les codes de couleurs
 
        If Cellule.Characters(j, 1).Font.ColorIndex < -1 Then       'égal à -4105 déjà présents dans la cellule
            Cellule.Characters(j, 1).Font.ColorIndex = 1            'Corrige le code par le noir
            'MsgBox ("erreur couleur police cellule H" & i & " position " & j)
 
        End If
 
    Next j
 
    Do                              'Boucle qui permet de traiter tous les caractères de la cellule traitée
 
        If LnCell = 0 Then Exit Do  'Sort de la boucle pour les celulles vides
 
        While IsNumeric(Cellule.Characters(Debut, Longueur).Font.ColorIndex) And (Debut + Longueur) < LnCell + 2
            Longueur = Longueur + 1 'Boucle qui permet de connaitre la longeur de la chaine de caractères
                                    'de même couleur + 1 caractère (on sort de la boucle lorsque deux caractéres
                                    'consécutifs n'ont pas la même couleur)
        Wend
 
        If Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex > -1 Then  'Test pour discriminer la couleur -4105
            Couleur = Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex
        End If
 
    MsgBox (Cellule.Characters(Debut, Longueur - 1).Caption)
 
 
        Select Case Couleur
            Case 1                  'Couleur noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 10                 'Couleur Verte
                Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex = 1 'On met la police en noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 14                 'Autre couleur verte
                Cellule.Characters(Debut, Longueur - 1).Font.ColorIndex = 1 'On met la police en noir
                Debut = Debut + Longueur - 1                                'Incrémentation compteur
            Case 3                  'Couleur rouge
                If Cellule.Characters(Debut, 1).Text = " " Then         'Si le premier caractere est un espace, on le
                    Cellule.Characters(Debut, 1).Font.ColorIndex = 1    'met en couleur noire et on ne le supprime pas.
                    Cellule.Characters(Debut + 1, Longueur - 2).Delete  'Suppression du reste
                    Debut = Debut + 1                                       'Incrémentation compteur
                    LnCell = LnCell - Longueur + 2   'Modification de la longueur totale de la chaine à traiter
                Else
                    Cellule.Characters(Debut, Longueur - 1).Delete    'Si le premier caractère n'est pas un espace
                    LnCell = LnCell - Longueur + 1   'Modification de la longueur totale de la chaine à traiter                   'on supprime l'ensemble
                End If
 
        End Select
 
    Longueur = 1
 
    Loop While Debut < LnCell
 
    'Rows(i & ":" & i).EntireRow.AutoFit             'adapte la hauteur de la ligne en fonction du contenu de la cellule
 
    Next i
    'Columns("H:H").Select
    'With Selection
    '    .VerticalAlignment = xlTop
    '    .Orientation = 0
    '    .AddIndent = False
    '    .IndentLevel = 0
    '    .ShrinkToFit = False
    '    .ReadingOrder = xlContext
    '    .MergeCells = False
    'End With
   ' Application.ScreenUpdating = True
End Sub

Je crois que avoir déjà vu quelque part Characters.Delete est limitée à 255. Je ne suis pas sur.

Sinon une alternative pour supprimer la texte en rouge et en en colorant le tout en noir

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub MisEnForme()
Dim i As Integer, j As Integer
Dim Tmp As String
 
For i = 11 To 12
    With Worksheets("Feuil1").Cells(i, 3)
        For j = 1 To Len(.Value)
            If .Characters(j, 1).Font.ColorIndex <> 3 Then Tmp = Tmp & .Characters(j, 1).Caption
        Next j
        .Value = Tmp
        Tmp = ""
        .Font.ColorIndex = 0
    End With
Next i
End Sub

fonction characters

bonsoir,

Pour ma gouverne, j'ai fait le petit essai suivant avec 460 caractères sans problème.
Je n'ai pour l'heure pas d'autre réponse à apporter mais ne désespère pas.
Code:

1 2 3 4 5 6 7 Sub car() longueur = Len(Cells(1, 1)) MsgBox longueur 'essai fait avec 460 caractères sans problème Cells(1, 1).Characters(1, longueur).Font.Italic = True Cells(1, 1).Characters(1, longueur).Delete End Sub
Cordialement,

Bonsoir Paul

Fais ce test

En A1, écris un texte dont le nombre de caractères dépasse 256
Colorie une partie du texte en rouge
Lance cette macro
Code:

1 2 3 4 5 6 7 8 Sub Test() Dim i As Integer, n As Integer n = Len(Cells(1, 1)) For i = n To 1 Step -1 If Cells(1, 1).Characters(i, 1).Font.ColorIndex = 3 Then Cells(1, 1).Characters(i, 1).Delete Next i End Sub
Fais le même test avec un texte <=256 caractères.

fonction characters

bonsoir Mercatog,

En effet, il passe avec 256 caractères mais pas avec 257.

Je ne sais donc pas comment VBA à compris mon bout de code sans boucle?

Cordialement,

Bonjour messieurs,

Merci pour ces réponses. Je vais tester vos codes alternatifs et je vous tiens au courant de la réussite ou non.

CCordialement

bonjour, regarde ça

Code:

1
2
3
4
5
6
Sub test()
Dim a As String
a = "123456789"
Mid(a, 1, 2) = "~"
a = Replace(a, "~", "")
End Sub