Discussion :

[chris09300]

bonsoir
est il possible de couper un texte si¡'il est superieur a 90 caracteres, et de mettre la suite du texte sur la ligne suivante avec des espaces devant.
et ainsi de suite sur les 30 lignes suivantes.
merci
cris

[mercatog]

Bonsoir
Essaies ceci (le etxt initial en A1 de feuil3, les résultat à partir de A2 vers le bas)

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
Sub Test()
Dim Mot As String, Txt As String
Dim i As Integer, j As Integer, Nb As Integer
Dim Tb
 
Nb = 1
j = 2
With Sheets("Feuil3")
    Mot = .Range("A1").Value
    Tb = Split(Mot)
    Do
        Do While Len(Txt) <= Nb And i < UBound(Tb)
            Txt = Txt & " " & Tb(i)
            i = i + 1
        Loop
        .Range("A" & j).Value = Trim(Txt)
        j = j + 1
        Txt = ""
    Loop Until i = UBound(Tb)
End With
End Sub

[JPierreM]

Bonjour,

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 Test()
Dim depart As Integer
Dim texte As String
Dim nouvellePhrase As String
 
   MsgBox "Découpe une phrase en chaines de 90 caractères maxi" _
   & Chr(13) & "sans couper les mots"
    depart = 5
    texte = [A1]
 
    Do While Len(texte) >= 90
        nouvellePhrase = Left(texte, 90)
        nouvellePhrase = InStrRev(nouvellePhrase, " ")
        Cells(depart, 1) = Left(texte, nouvellePhrase - 1)
        texte = Mid(texte, nouvellePhrase + 1)
        depart = depart + 1
    Loop
 
    Cells(depart, 1) = texte
 End Sub

[chris09300]

bonsoir jpierreM
j'ai utiliser ton code, ca fonctionne, je souhaiterais partir de la cellule B23, car c'est la qu'est ma premiere phrase,
elle se divise bien, et va a la ligne suivante.
mais si j'ai un autre texte en dessous, il faudrait que j'insere une ligne.
comment faire une fois que le texte est bien decouper, que le code recherche, s'il y a un autre texte dans les lignes suivantes et les decouper aussi, en inserant a chaque fois une ligne pour decaler le texte qui suis sur la ligne suivante, je ne sais pas si j'ai ete assez clair.
merci cris

Mercatog
le code que tu m'a donne, coupe toute la phrase, a chaque mot.
merci

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
 
Sub Test()
Dim depart As Integer
Dim texte As String
Dim nouvellePhrase As String
 
   MsgBox "Découpe une phrase en chaines de 90 caractères maxi" _
   & Chr(13) & "sans couper les mots"
    depart = 24
    texte = [B23]
 
    Do While Len(texte) >= 90
        nouvellePhrase = Left(texte, 90)
        nouvellePhrase = InStrRev(nouvellePhrase, " ")
        Cells(depart, 1) = Left(texte, nouvellePhrase - 1)
        texte = Mid(texte, nouvellePhrase + 1)
        depart = depart + 1
    Loop
 
    Cells(depart, 1) = texte
 End Sub

[mercatog]

Bonsoir
Oui bien sûr, j'avais omis de préciser que la variable Nb doit comporter le nombre max de lettres (J'avais mis 1 pour tester les extrêmes)

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
Sub Test()
Dim Mot As String, Txt As String
Dim i As Integer, j As Integer, Nb As Integer
Dim Tb
 
Nb = 90                                                              'Nb de lettres max par ligne
j = 24                                                               'Ligne de début de collage du résultat
Application.ScreenUpdating = False
With Sheets("Feuil3")                                                'A adapter
    Mot = .Range("B23").Value
    Tb = Split(Mot)
    Do
        Do While Len(Txt) <= Nb And i <= UBound(Tb)
            Txt = Txt & " " & Tb(i)
            i = i + 1
        Loop
        If .Range("B" & j).Value <> "" Then .Rows(j).Insert
        .Range("B" & j).Value = Trim(Txt)
        j = j + 1
        Txt = ""
    Loop Until i >= UBound(Tb)
End With
End Sub

[EDIT]
J'ai édité le code initial pour pallier à une petite coquille

[chris09300]

bonsoir mercatog
le code bug a
j = j + 1
il tourne sans cesse, je suis obliger de faire plusieurs fois esc, pr arreter le code.
cris

[mercatog]

J'avais édité le code (après test)

[chris09300]

excuse moi, mais je comprend pas ce que tu me dit, sur ton message.

apres verification, cela marche en partie, car il me coupe bien le texte,en le mettant a la ligne mais il me supprime systematiquement le dernier mot, quelque soit la longueur du texte.

comment fait on pour faire continuer la macro, en recherchant s'il y a du texte en dessous. des qu'il trouve une ligne vierge ,la macro s'arrete.

et comment supprimer l'ancien texte.

merci mercatog
cris

[JPierreM]

Bonjour,

Copie les données à partir de la cellule B23 et décale toutes les lignes vers le bas pour éviter de supprimer les infos contenues éventuellement en dessous

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
Sub Test()
Dim depart As Integer
Dim texte As String
Dim nouvellePhrase As String
 
   MsgBox "Découpe une phrase en phrases de 90 caractères maxi" _
   & Chr(13) & "sans couper les mots"
    depart = 23
    texte = [A1]
 
    Application.ScreenUpdating = False
    Do While Len(texte) >= 90
        nouvellePhrase = Left(texte, 90)
        nouvellePhrase = InStrRev(nouvellePhrase, " ")
        Rows(depart).Insert shift:=xlDown
        Cells(depart, 2) = Left(texte, nouvellePhrase - 1)
        texte = Mid(texte, nouvellePhrase + 1)
        depart = depart + 1
    Loop
 
    Rows(depart).Insert shift:=xlDown
    Cells(depart, 2) = texte
    Application.ScreenUpdating = true
 End Sub

[chris09300]

bonsoir jpierreM
j'ai tester le code ca fonctionne, j'ai modifie le code voir en rouge.
donc la phrase que je viens de couper se retrouve en ligne 23, je souhaiterais la supprimer.
et ensuite pourvoir continuer sur la ligne suivante, car j'ai encore un texte, et ainsi de suite jusqu'a la derniere ligne avec du texte.
as tu une idee.
cris

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
Sub Test()
Dim depart As Integer
Dim texte As String
Dim nouvellePhrase As String
   
   
'   MsgBox "Découpe une phrase en chaines de 90 caractères maxi" _
'   & Chr(13) & "sans couper les mots"
    depart = 21
    texte = [B21]
   
    Application.ScreenUpdating = False
    Do While Len(texte) >= 90
        nouvellePhrase = Left(texte, 90)
        nouvellePhrase = InStrRev(nouvellePhrase, " ")
        Rows(depart).Insert Shift:=xlDown
        Cells(depart, 2) = Left(texte, nouvellePhrase - 1)
        texte = Mid(texte, nouvellePhrase + 1)
        depart = depart + 1
    Loop
    
    Rows(depart).Insert Shift:=xlDown
    Cells(depart, 2) = texte
    Application.ScreenUpdating = True
 End Sub

[mercatog]

Pour couper toutes les cellules à partir de la ligne 23 de la colonne B en insérant autant de lignes que de coupures

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
Sub Test()
Dim i As Integer, j As Integer, Nb As Integer
Dim Mot As String, Txt As String
Dim LastLig As Long, k As Long
Dim Tb
 
Nb = 90                                                              'Nb de lettres max par ligne
Application.ScreenUpdating = False
With Sheets("Feuil2")                                                'A adapter
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    If LastLig >= 23 Then
        For k = LastLig To 23 Step -1
            j = k + 1
            Mot = .Range("B" & k).Value
            Tb = Split(Mot)
            Do
                Do While Len(Txt) <= Nb And i <= UBound(Tb)
                    Txt = Txt & " " & Tb(i)
                    i = i + 1
                Loop
                If .Range("B" & j).Value <> "" Then .Rows(j).Insert
                .Range("B" & j).Value = Trim(Txt)
                j = j + 1
                Txt = ""
            Loop Until i >= UBound(Tb)
            .Rows(k).Delete
            Erase Tb
            i = 0
        Next k
    End If
End With
End Sub

[chris09300]

super Mercatog
ca fonctionne pile poil.
merci beaucoup.
cris