XL 2010 Insérer une une ligne et copier la cellule d'en dessous

Sub Macro4()
Dim r As Range
Application.ScreenUpdating = False
Set r = Columns("A:A").SpecialCells(xlCellTypeBlanks)
r.FormulaR1C1 = "=R[-1]C"
Columns("A:A") = Columns("A:A").Value
End Sub

Sub test()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In Worksheets
If Application.CountA(ws.Columns(2)) > 0 Then
insérer ws, 2
End If
Next
End Sub
Private Sub insérer(F As Worksheet, col&)
Dim DLig&, i&, r As Range
DLig = F.Cells(Rows.Count, col).End(xlUp).Row
For i = DLig To 2 Step -1
If F.Cells(i, col).Value <> F.Cells(i - 1, col).Value Then F.Rows(i).Insert
Next i
Set r = F.Cells(1, col).Resize(F.Cells(Rows.Count, col).End(3).Row).SpecialCells(4)
Set r = Union(r, F.Cells(Rows.Count, col).End(3)(2))
r = "=R[-1]C": r.Interior.ColorIndex = 15
F.Columns(col) = F.Columns(col).Value
Set r = Nothing
End Sub

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, j%
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
'---RAZ pour le cas où la macro a déjà été exécutée---
ActiveSheet.Cells.FormatConditions.Delete 'supprime les MFC
With ActiveSheet.UsedRange
    .Columns(1).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(0) = "=1/OR(RC[1]="""",RC[2]=R[1]C[3])"
    .Columns(0) = .Columns(0).Value 'supprime les formules
    .EntireRow.Sort .Columns(0), xlDescending, Header:=xlYes 'tri pour regrouper et accélérer
    .Columns(0).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'supprime les lignes
    .Columns(0).EntireColumn.Delete
End With
'---traitement---
With ActiveSheet.UsedRange
    ncol = .Columns.Count
    If ncol < 3 Then ncol = 3
    tablo = .Resize(, ncol) 'matrice, plus rapide
    ReDim resu(1 To Rows.Count, 1 To ncol)
    For i = 2 To UBound(tablo)
        If tablo(i, 2) = tablo(i - 1, 2) Then
            n = n + 1
        Else
            n = n + 3
            resu(n - 1, 1) = tablo(i, 1)
            resu(n - 1, 2) = tablo(i, 3)
        End If
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    .Offset(1).Resize(n) = resu 'restitution
End With
'---mise en forme conditionnelle (MFC)---
With ActiveSheet.UsedRange.Offset(1)
    .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
    .FormatConditions(1).Font.Bold = True 'gras
    .FormatConditions(1).Interior.ColorIndex = 48 'gris foncé
End With
End Sub

Sub Insertion()
'se lance par Ctrl+M
Dim ncol%, tablo, resu(), i&, n&, j%
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
'---RAZ pour le cas où la macro a déjà été exécutée---
ActiveSheet.Cells.FormatConditions.Delete 'supprime les MFC
With ActiveSheet.UsedRange
    .Columns(1).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(0).Offset(1) = "=1/OR(RC[1]="""",R[-1]C[1]="""")"
    .Columns(0).Offset(1) = .Columns(0).Offset(1).Value 'supprime les formules
    .EntireRow.Sort .Columns(0), xlDescending, Header:=xlYes 'tri pour regrouper et accélérer
    .Columns(0).SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'supprime les lignes
    .Columns(0).EntireColumn.Delete
End With
'---traitement---
With ActiveSheet.UsedRange
    ncol = .Columns.Count
    If ncol < 3 Then ncol = 3
    tablo = .Resize(, ncol) 'matrice, plus rapide
    ReDim resu(1 To Rows.Count, 1 To ncol)
    For i = 2 To UBound(tablo)
        If tablo(i, 2) = tablo(i - 1, 2) Then
            n = n + 1
        Else
            n = n + 3
            resu(n - 1, 1) = tablo(i, 1)
            resu(n - 1, 2) = tablo(i, 3)
        End If
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    .Offset(1).Resize(n) = resu 'restitution
End With
'---mise en forme conditionnelle (MFC)---
With ActiveSheet.UsedRange.Offset(1)
    .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(0, 1).Address(0, 1) & "="""""
    .FormatConditions(1).Font.Bold = True 'gras
    .FormatConditions(1).Interior.ColorIndex = 48 'gris foncé
End With
End Sub