Discussion :

[dbgdbg]

Bonjour,

J'ai un soucis avec VBA

Je souhaiterais compléter une cellule Excel avec du texte saisi via un TextBox sans supprimer sa mise en forme (par exemple : certains mots sont en gras, il existe des retours chariots...)

Auriez-vous la solution?

Merci!

[PMO2017]

Bonjour,

D'après ce que j'ai compris, j'ai fait un UserForm avec une TextBox et un CommandButton.
Ce qui est tapé dans la TextBox est ajouté à la cellule voulue.

1) code du UserForm

Code :

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

1
2
3
4
5
Private Sub CommandButton1_Click()
If TextBox1 <> "" Then
 Call CompleteTexte(Sheets("Feuil1").[a19], TextBox1)   'les 2 paramètres sont à adapter
End If
End Sub

2) code à copier dans un 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
Type StructChar
  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
  ThemeColor As Variant
  TintAndShade As Long
  ThemeFont As Long
  Color As Long
End Type
 
Sub CompleteTexte(Cellule As Range, TexteAdd As String)
Dim Chars() As StructChar
Dim i&
'---
If IsNumeric(Cellule) Then Exit Sub
ReDim Chars(1 To Cellule.Characters.Count)
Application.ScreenUpdating = False
On Error Resume Next
'--- Cherche les propiétés de chaque caractère déjà existant ---
For i& = 1 To UBound(Chars)
  With Cellule.Characters(Start:=i&, Length:=1).Font
    Chars(i&).FontStyle = .FontStyle
    Chars(i&).Name = .Name
    Chars(i&).OutlineFont = .OutlineFont
    Chars(i&).Shadow = .Shadow
    Chars(i&).Size = .Size
    Chars(i&).Strikethrough = .Strikethrough
    Chars(i&).Subscript = .Subscript
    Chars(i&).Superscript = .Superscript
    Chars(i&).ThemeColor = .ThemeColor
    Chars(i&).ThemeFont = .ThemeFont
    Chars(i&).TintAndShade = .TintAndShade
    Chars(i&).Underline = .Underline
    Chars(i&).Color = .Color
  End With
Next i&
'--- Ajoute le nouveau texte ---
Cellule = Cellule & TexteAdd
'--- Applique les propiétés des caractères existants ---
For i& = 1 To UBound(Chars)
  With Cellule.Characters(Start:=i&, Length:=1).Font
    .FontStyle = Chars(i&).FontStyle
    .Name = Chars(i&).Name
    .OutlineFont = Chars(i&).OutlineFont
    .Shadow = Chars(i&).Shadow
    .Size = Chars(i&).Size
    .Strikethrough = Chars(i&).Strikethrough
    .Subscript = Chars(i&).Subscript
    .Superscript = Chars(i&).Superscript
    .ThemeColor = Chars(i&).ThemeColor
    .ThemeFont = Chars(i&).ThemeFont
    .TintAndShade = Chars(i&).TintAndShade
    .Underline = Chars(i&).Underline
    .Color = Chars(i&).Color
  End With
Next i&
On Error GoTo 0
Application.ScreenUpdating = True
End Sub