Renvoi a la ligne insérer pousser

hemardjean

XLDnaute Occasionnel
Bonjour le forum bonjour a tous

En cherchant sur le forum j’ai trouvé un code pour couper et insérer, mais il ne pousse pas le texte qui se trouve en dessous mais il écrit dessus. Peut-on le corriger.

Le code est le suivant :

Option Explicit
Sub TronText()
Dim h1 As Double, h2 As Double, i As Byte, n As Byte, X As Integer, Z As Integer
Dim NbCaract As Integer, TronText As String, Restext As String
Application.ScreenUpdating = False
If Len(ActiveCell) = 0 Then Exit Sub
With ActiveCell
h1 = .Height
.WrapText = True
h2 = .Height
.WrapText = False
If h2 = h1 Then Exit Sub
X = Int(h2 / h1) + 1
Restext = .Text
Z = Round(Len(Restext) / X)
For i = 1 To X
n = 0
NbCaract = Len(Restext)
If NbCaract = 0 Then Exit For
Do
n = n + 1
TronText = Left(Restext, Z + n - 1)
Loop Until Right(TronText, 1) = " " Or Len(TronText) >= NbCaract
ActiveCell.Offset(i - 1, 0) = TronText
Restext = Right(Restext, NbCaract - Len(TronText))
Next i
End With
End Sub


Merci de votre aide

Cordialement A+
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas