Discussion :

[jucva]

Bonjour,

Je souhaite insérer du texte dans une cellule en vba sans modifier la mise en forme du texte déjà présent dans la cellule.

Je penser simplement faire un :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cells(x,y)= Cells(x,y).Value & Mystring

Mais la mise en forme du contenu de ma cellule est écrasé.

Si quelqu'un à une idée???


Merci

[Kimy_Ire]

Bonjour jucva,

Très proche !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cells(x,y).Value = Cells(x,y).Value & Mystring

Cordialement,
Kimy

[PMO2017]

Je souhaite insérer du texte dans une cellule en vba sans modifier la mise en forme du texte déjà présent dans la cellule.

Bonjour,

C'est plus compliqué qu'on pourrait le croire.
1) Il faut mémoriser les propriétés de chaque caractère du texte existant
2) Faire l'ajout de l'autre texte à la suite du texte existant
3) Rapporter les propriétés mémorisées au texte existant

***************
Pour ce faire :
1) Copiez le code suivant dans un nouveau module Standard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Private Module
 
Type structStyleChar
  Name  As String
  FontStyle As String
  Size As Long
  Strikethrough As Boolean
  Superscript As Boolean
  Subscript As Boolean
  OutlineFont As Boolean
  Shadow As Boolean
  Underline As Long
  Color As Long
  ThemeColor  As Long
  TintAndShade  As Long
  ThemeFont  As Long
End Type
 
Enum EnumOperation
  Memorisation
  Inscription
End Enum
 
Public StyleChar() As structStyleChar
 
Public Function ConserverMiseEnFormeTexteInitial(Cellule As Range, Operation As EnumOperation)
Dim i&
'---
If Operation = Memorisation Then
  ReDim StyleChar(1 To Len(Cellule))
  On Error Resume Next
  For i& = 1 To UBound(StyleChar)
    With Cellule.Characters(Start:=i&, Length:=1).Font
      StyleChar(i&).Name = .Name
      StyleChar(i&).FontStyle = .FontStyle
      StyleChar(i&).Size = .Size
      StyleChar(i&).Strikethrough = .Strikethrough
      StyleChar(i&).Superscript = .Superscript
      StyleChar(i&).Subscript = .Subscript
      StyleChar(i&).OutlineFont = .OutlineFont
      StyleChar(i&).Shadow = .Shadow
      StyleChar(i&).Underline = .Underline
      StyleChar(i&).Color = .Color
      StyleChar(i&).ThemeColor = .ThemeColor
      StyleChar(i&).TintAndShade = .TintAndShade
      StyleChar(i&).ThemeFont = .ThemeFont
    End With
  Next i&
  On Error GoTo 0
Else
  On Error Resume Next
  For i& = 1 To UBound(StyleChar)
    With Cellule.Characters(Start:=i&, Length:=1).Font
      .Name = StyleChar(i&).Name
      .FontStyle = StyleChar(i&).FontStyle
      .Size = StyleChar(i&).Size
      .Strikethrough = StyleChar(i&).Strikethrough
      .Superscript = StyleChar(i&).Superscript
      .Subscript = StyleChar(i&).Subscript
      .OutlineFont = StyleChar(i&).OutlineFont
      .Shadow = StyleChar(i&).Shadow
      .Underline = StyleChar(i&).Underline
      .Color = StyleChar(i&).Color
      .ThemeColor = StyleChar(i&).ThemeColor
      .TintAndShade = StyleChar(i&).TintAndShade
      .ThemeFont = StyleChar(i&).ThemeFont
    End With
  Next i&
  On Error GoTo 0
End If
End Function

2) Appelez la fonction ConserverMiseEnFormeTexteInitial comme dans l'exemple suivant (où le texte initial est en A1)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub VotreTraitement()
'--- Affectations pour l'exemple (correspond à la cellule A1) ---
Dim x
Dim y
Dim Mystring
'---
x = 1
y = 1
Mystring = " la pucelle d'Orléans"
'-----------------------------------------------------------------
 
'--- Mémorise les propriétés de chaque caractère de la chaîne existante ---
Call ConserverMiseEnFormeTexteInitial(Cells(x, y), Memorisation)
 
'--- Ajout d'un quelconque texte en fin de chaîne ---
Cells(x, y) = Cells(x, y) & Mystring
 
'--- Inscrit les propriétés de chaque caractère de la chaîne existante ---
Call ConserverMiseEnFormeTexteInitial(Cells(x, y), Inscription)
End Sub

Je mets une pièce jointe pour plus de facilité.