Renvoi a la ligne insérer pousser

[hemardjean]

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+