Discussion :

[JukeBoX]

Bonsoir le forum

Voilà je cherche un code VBA qui permettrait de forcer un retour à la ligne suivant un certain nombre de caractères (j'adapterai) et pour compliquer la tâche suivant la taille de la police
Par exemple :

Cellule ("C2")
- Si taille police 16 alors retour à la ligne après 40 caractères
- Si taille police 10 alors retour à la ligne après 60 caractères
- ...

Je ne sais pas si cela est possible, j'ai cherché sur Internet mais pas trouvé de solution

Merci !

[ARTURO83]

Bonjour,

Faites un essai avec ceci (A copier dans le module de la feuille)

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
    End If
Sortie:
    Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
    End If
Sortie:
    Application.EnableEvents = True
End Sub

Cdlt

[JukeBoX]

Bonjour ARTURO83

Merci pour ton message et ton code !
Je l'ai testé et cela fonctionne mais le seul hic c'est que si l'on resélectionne la cellule cela rajoute un retour à la ligne
Peut-on éviter cela ?

Merci

[ARTURO83]

Alors supprimez la macro "Private Sub Worksheet_SelectionChange(ByVal Target As Range)", ainsi cela ne fonctionnera uniquement lorsque vous saisirez une valeur dans la cellule.

[JukeBoX]

J'ai testé du coup mais ça ne va pas
Par contre je pensais plutôt à utiliser un code qui ferait un retour à la ligne tous les 30 caractères par exemple si police 16 et tous les 50 caractères si police 10
Peut-être que ça serait plus simple non ?

Qu'en penses-tu ?

Edit : J'ai pu faire quelques recherches et je suis tombé sur ce code qui fonctionne bien mais il ajuste automatiquement la largeur et hauteur de la cellule ce que je ne souhaite pas
Est-il possible d'adapter ce code ?

Le voici :

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n%, P As Range, r As Range, s1, i%, s2, x$, t$, j%
n = 20 'nombre maximum de caractères par ligne, paramétrable
Set P = Range("B6:B" & Rows.Count) 'à adapter
Set r = Intersect(Target, P, Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False = False
Application.EnableEvents = False 'désactive les événements
For Each r In r 'si entrées multiples (copier-coller)
  s1 = Split(r, vbLf) 'tableau des paragraphes
  For i = 0 To UBound(s1)
    s2 = Split(RTrim(s1(i))) 'tableau des mots
    x = "": t = ""
    For j = 0 To UBound(s2)
      x = t & IIf(j, " ", "") & Left(s2(j), n)
      t = t & vbLf & Left(s2(j), n)
      t = IIf(Len(x) - InStrRev(x, vbLf) > n, t, x)
    Next j
    s1(i) = t
  Next i
  r = Join(s1, vbLf)
Next r
'---ajustement des lignes et colonnes---
P.WrapText = False
P.RowHeight = 10
P.ColumnWidth = 255
P.WrapText = True
P.Rows.AutoFit
P.Columns.AutoFit
Application.EnableEvents = True 'réactive les événements
End Sub

Merci

[ARTURO83]

Bonjour,

Si ça vous convient alors il suffit de supprimer la partie "Ajustement des lignes et colonnes"
'---ajustement des lignes et colonnes---
'P.WrapText = False
'P.RowHeight = 10
'P.ColumnWidth = 255
'P.WrapText = True
'P.Rows.AutoFit
'P.Columns.AutoFit

Sinon, j'avais pensé à une autre solution, on colore le fond de la cellule une fois qu'elle est traitée, ainsi lorsque la cellule est à nouveau sélectionnée, le code détecte la couleur de fond de la cellule et si ce dernier est d'une certaine couleur alors la cellule n'est plus modifiable, c'est une sorte de verrouillage (j'ai mis une couleur qui s'approche du blanc pour ne pas modifier l'apparence de la cellule), Si l'on veut modifier la cellule il suffit de supprimer la couleur de fond.
C'est une idée, ça vaut ce que ça vaut!

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
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" And Target.Interior.Color <> 16579836 Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
    End If
Sortie:
    Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" And Target.Interior.Color <> 16579836 Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
    End If
Sortie:
    Application.EnableEvents = True
End Sub

Cdlt

[JukeBoX]

Merci pour ton retour ARTURO83

J'ai essayé de supprimer la partie que tu m'as dit

Code :

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

1
2
3
4
5
6
7
'---ajustement des lignes et colonnes---
'P.WrapText = False
'P.RowHeight = 10
'P.ColumnWidth = 255
'P.WrapText = True
'P.Rows.AutoFit
'P.Columns.AutoFit

Mais du coup le code ne fonctionne plus... cela ne fait plus le retour à la ligne

J'ai essayé ta nouvelle proposition avec changement de couleur de cellule et idem ça ne fonctionne pas on dirait que ça ne colore pas la cellule.

Je pense que ça ne doit pas être évident à mettre en place ce que je souhaite.
Pour info je passe par une textbox pour insérer la valeur dans une cellule, peut-être qu'il y a une solution de ce côté là ?

Merci pour ton aide

[ARTURO83]

Bon jour,

J'ai essayé ta nouvelle proposition avec changement de couleur de cellule et idem ça ne fonctionne pas on dirait que ça ne colore pas la cellule.

Oui effectivement je n'ai pas dû enregistrer la dernière modification que j'avais faite.

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" And Target.Interior.Color <> 16579836 Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
        Target.Interior.Color = 16579836
        Target.WrapText = True
    End If
Sortie:
    Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim NbCar As Long, NbCr As Long, i As Long, PosDep As Long
    Dim ValCell As String
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" And Target.Interior.Color <> 16579836 Then
        If Target.Font.Size = 10 And Len(Target) > 60 Then
            NbCar = 60 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        ElseIf Target.Font.Size = 16 And Len(Target) > 40 Then
            NbCar = 40 'Nombre de caractères max
            NbCr = Len(Target) / NbCar 'Nombre de retour ligne
        End If
        PosDep = 1
        ValCell = Target
        For i = 1 To Int(NbCr) + 1
            Cellule = Cellule & Chr(10) & Mid(ValCell, PosDep, NbCar) '& Chr(10) ' & Right(target, Len(target) - Nbcar)
            PosDep = (NbCar * i) + 1
        Next i
        Target = Right(Cellule, Len(Cellule) - 1)
        Target.Interior.Color = 16579836
        Target.WrapText = True
    End If
Sortie:
    Application.EnableEvents = True
End Sub

Chez moi le retour à la ligne se fait bien, sinon j'ai ajouté "Target.WrapText = True"

Cdlt

[JukeBoX]

J'ai essayé avec ton nouveau code et la cellule se colore bien mais pas de retour à la ligne, j'ai loupé quelque chose ?

[ARTURO83]

Pourtant:


Pièce jointe 600614

[JukeBoX]

Est-ce que ça serait possible d'ajuster le texte pour que la police soit la plus grande possible pour occuper toute la cellule et donc que la police diminue si le texte est plus long et toujours en occupant l'intégralité de la cellule ?

En fait c'est ce que je recherche à faire depuis le début mais j'ai essayé en jouant sur le nombre de caractère et aussi avec les retours lignes (par exemple si 1 retour ligne alors police à 16 si deux retours ligne alors police à 10...)

[ARTURO83]

Bonjour,

Essayez ceci, toujours par rapport au contenu de la cellule C2, la police s'adaptera à la largeur de la cellule en fonction du nombre de caractères. La largeur de la cellule est conservée.

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Larg_Col_Avant As Double, Larg_Col_Après As Double
    On Error GoTo Sortie
    Application.EnableEvents = False
    If Target.Address = "$C$2" Then
        Application.ScreenUpdating = False
        Larg_Col_Avant = Columns(3).ColumnWidth
        Columns(3).EntireColumn.AutoFit
        Larg_Col_Après = Columns(3).ColumnWidth
        If Larg_Col_Après > Larg_Col_Avant Then
            Do While Larg_Col_Après > Larg_Col_Avant
                Cells(2, "C").Font.Size = Cells(2, "C").Font.Size - 1
                Columns(3).EntireColumn.AutoFit
                Larg_Col_Après = Columns(3).ColumnWidth
            Loop
        ElseIf Larg_Col_Après < Larg_Col_Avant Then
            Do While Larg_Col_Après < Larg_Col_Avant
                Cells(2, "C").Font.Size = Cells(2, "C").Font.Size + 1
                Columns(3).EntireColumn.AutoFit
                Larg_Col_Après = Columns(3).ColumnWidth
            Loop
        End If
        Columns(3).ColumnWidth = Larg_Col_Avant
    End If
Sortie:
    Application.EnableEvents = True
End Sub

Cdlt

[JukeBoX]

Bonjour ARTURO83

Le code fonctionne bien c'est vraiment ce que je recherchais !

Par contre cela ne fonctionne plus s'il y a plusieurs lignes dans la cellule (retour à la ligne) une idée ?

Merci encore

EDIT : Est-il possible que le code s'adapte aussi à la hauteur de la cellule car j'ai remarqué que le texte pouvait être tronqué en hauteur

[JukeBoX]

Je viens de chercher de mon côté et finalement je pense qu'il est impossible d'ajuster la taille du texte dans une cellule s'il y a plusieurs retour de lignes.
Cela fonctionne uniquement sur une seule ligne.

Est-ce que le forum peut me confirmer cela ?

Merci

[Thumb down]

bonsoir,

Code :

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

1
2
3
4
5
6
7
8
9
10
Dim nb As Integer, txt As String
nb = IIf(Target.Font.Size = 16, 40, 60)
rest = Len(Target.Text) Mod nb
txt = ""
For i = Len(Target.Text) + 1 - rest To 0 Step nb * -1
If txt <> "" Then txt = vbCrLf & txt
txt = Trim(Mid(Target.Text & String(nb, " "), i, nb)) & txt
Next
Debug.Print txt
Target = txt

[JukeBoX]

Salut Thumb down

Peux-tu m'expliquer ton code et comment dois-je l'utiliser ?

Je te remercie

[Thumb down]

Cellule ("C2")
- Si taille police 16 alors retour à la ligne après 40 caractères
- Si taille police 10 alors retour à la ligne après 60 caractères

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
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$C$2" Then
    Application.EnableEvents = False
        Dim nb As Integer, txt As String
        nb = IIf(Target.Font.Size = 16, 40, 60) 'si Font.Size = 16
        rest = Len(Target.Text) Mod nb 
        txt = ""
 
        For i = Len(Target.Text) + 1 - rest To 0 Step nb * -1 'on commence par la fin avec un pas de -40 ou -60
            If txt <> "" Then txt = Chr(10) & txt
            txt = Trim(Mid(Target.Text & String(nb, " "), i, nb)) & txt
        Next
        Debug.Print txt
        Target = txt
        Target.WrapText = True
        Application.EnableEvents = True
   End If
End Sub

[JukeBoX]

Merci Thumb down

Du coup pour le moment j'utilise une macro qui compte le nombre de caractère et change la taille de la police suivant le résultat + si retour à la ligne changement de taille également et j'ai rajouté un userform pour que l'utilisateur puisse modifier si besoin la taille de la police (5 choix possible)

Merci encore à toi et ARTURO83 pour votre aide !