Inserer un ligne et copier les valeurs de la cellule du dessus

Option Explicit

Sub Tst()
Dim i As Long, LastRow As Long
Dim Nb As Integer, Ar() As String, s As String
    Application.ScreenUpdating = False
    LastRow = ShTest.Range("A" & Rows.Count).End(xlUp).Row
    For i = LastRow To 1 Step -1
        s = ShTest.Range("A" & i)
        Ar = Split(s, ";")
        Nb = UBound(Ar)
        If Nb > 0 Then
            With ShTest
                .Rows(i + 1 & ":" & i + Nb).Insert Shift:=xlDown
                .Range("A" & i).Copy
                .Range("A" & i + 1 & ":A" & i + Nb).PasteSpecial Paste:=xlPasteValues
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub