Bonjour,
Voilà plusieurs jours que je galère pour insérer des retours à la ligne dans un ListBox, Mais à force de persévérance, j'ai trouvé une solution grâce à un code de J. BOISGONTIER et à SILKYROAD (https://silkyroad.developpez.com/VBA...nesCaracteres/) que je remercie grandement. Je souhaite partager ce code car au vu de mes nombreuses recherches (internet et autres) restées vaines, j'espère qu'elle pourra aider certains d'entre vous.
Pour faire fonctionner le code, il faut :
- une feuille Excel nommée "Commentaires" avec 4 colonnes (ex. : Date/N° Dossier/Commentaires/Commentaires à retraiter
- un UserForm avec un ComboBox, un TextBox et un ListBox
Userform :
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86 Option Explicit '************************************ 'Déclaration des variables publiques '************************************ Dim Rng, TblBD() Dim f As Worksheet Dim d As Variant Private Sub UserForm_Initialize() Dim d As Variant Dim i As Integer '**************** 'Base de données '**************** Set f = Sheets("Commentaires") Set Rng = f.Range("A2:C" & f.[A65000].End(xlUp).Row) TblBD = Rng.Value Me.ListBox1.ColumnCount = Rng.Columns.Count '************************** 'Alimentation du ComboBox1 '************************** Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(TblBD) To UBound(TblBD) d(TblBD(i, 1)) = "" Next i Me.ComboBox1.List = d.keys Me.ComboBox1 = "*" EnTeteListBox 'Entêtes du ListBox1 AfficherCommentaires 'Affichage des commentaires avec retour à la ligne (Module2) End Sub '****************************** 'Choix du dossier via ComboBox1 '****************************** Private Sub ComboBox1_click() AfficherCommentaires 'Affichage des commentaires avec retour à la ligne (Module2) End Sub '********************************** 'Validation du nouveau commentaire '********************************** Private Sub CommandButton1_Click() Dim n As Integer Dim f As Worksheet If Me.TextBox1 = "" Then MsgBox "Vous n'avez pas saisi de commentaires !" Exit Sub End If Set f = Sheets("Commentaires") n = f.Range("A" & Rows.Count).End(xlUp).Row + 1 f.Range("D" & n) = Me.TextBox1 Commentaire 'Retour à la ligne du nouveau commentaire (Module1) AfficherCommentaires 'Affichage des commentaires avec retour à la ligne (Module2) End Sub Sub EnTeteListBox() Dim X As Integer Dim Y As Integer Dim c As Integer Dim Lab As Control Dim tempcol As Variant X = Me.ListBox1.Left + 8 Y = Me.ListBox1.Top - 20 For c = 1 To Rng.Columns.Count Set Lab = Me.Controls.Add("Forms.Label.1") Lab.Caption = Rng.Offset(-1).Item(1, c) Lab.Top = Y Lab.Left = X Lab.Height = 24 Lab.Width = Rng.Columns(c).Width * 1# X = X + Rng.Columns(c).Width * 1 tempcol = tempcol & Rng.Columns(c).Width * 1# & ";" Next c On Error Resume Next Me.ListBox1.ColumnWidths = tempcol On Error GoTo 0 End Sub
Module1:
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 Option Explicit Sub Commentaire() Dim f As Worksheet Dim Requête As String Dim cible As String Dim chaine As String Dim n As Integer Dim i As Integer Dim X As Integer Set f = Sheets("Commentaires") n = f.Range("A" & Rows.Count).End(xlUp).Row + 1 Requête = f.Range("D" & n) 'Récupération du commentaire où insérer les retours à la ligne cible = Requête 'Copie du commentaire à retraiter dans la variable "cible" qui sera ensuite alimentée par paquets de 50 caractères Requête = "" 'Vidage de la variable Requête qui sera réalimentée par le commentaire avec les retours à la ligne For i = 1 To Len(cible) 'Boucle du 1er au dernier caractére du commentaire 'Recherche du 50ème caractère, si plus de caractère à traiter, finalisation du commentaire retraité X = InStr(50, cible, "") If X = 0 Then chaine = cible Requête = Requête & chaine 'Finaliation du commentaire avec les retours à la ligne Exit For End If chaine = Mid(cible, 1, X) 'Extraction des paquets de 50 caractères de la variable "cible" Requête = Requête & chaine & vbCrLf 'Réécriture du commentaire ligne par ligne cible = Mid(cible, Len(chaine) + 1) 'Réalimentation de la variable "cible" avec des 50 caractères suivants Next f.Range("A" & n) = Date f.Range("B" & n) = "145000" & "-" & n - 1 f.Range("C" & n) = Requête UserForm1.TextBox1.Text = "" End Sub
Module2 :
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 Option Explicit '**************************************************************** 'Affichage des commentaires dans un ListBox avec sauts de lignes '**************************************************************** Sub AfficherCommentaires() Dim TblBD2() As Variant Dim TblBD As Variant Dim Rng As Variant Dim nbColCmt As Integer Dim f As Worksheet Dim ligne As Integer Dim clé As String Dim colClé As Integer Dim i As Integer Dim k As Integer Dim lig As Integer Dim mx As Integer Dim j As Integer Set f = Sheets("Commentaires") Set Rng = f.Range("A2:C" & f.[A65000].End(xlUp).Row) TblBD = Rng.Value UserForm1.ListBox1.ColumnCount = Rng.Columns.Count nbColCmt = 1 ligne = 0 Dim a(): ReDim a(1 To nbColCmt) clé = UserForm1.ComboBox1: colClé = 1 For i = 1 To UBound(TblBD) If TblBD(i, colClé) Like clé Then ligne = ligne + 1 ReDim Preserve TblBD2(1 To UBound(TblBD, 2), 1 To ligne) TblBD2(1, ligne) = TblBD(i, 1): TblBD2(2, ligne) = TblBD(i, 2) ReDim TblM(1 To 20, 1 To nbColCmt) For k = 1 To nbColCmt a(k) = Split(TblBD(i, k + 2), vbLf) For lig = 0 To UBound(a(k)): TblM(lig + 1, k) = a(k)(lig): Next lig If UBound(a(k)) > mx Then mx = UBound(a(k)) Next k For j = 0 To mx ReDim Preserve TblBD2(1 To UBound(TblBD, 2), 1 To ligne) For k = 1 To nbColCmt: TblBD2(k + 2, ligne) = Replace(TblM(j + 1, k), Chr(13), ""): Next k ligne = ligne + 1 Next j End If Next i UserForm1.ListBox1.Column = TblBD2 End Sub
Partager