Macro pour insertion de plusieur ligne selon un critère

Sub InsereLignes()
    Dim p As Range, p2 As Range
    Dim L As Integer, C As Integer, i As Integer, j As Integer
    Dim tablo() As Variant, tablo2() As Variant
    
    Set p = Application.InputBox("Choisir la plage à convertir", , , , , , , 8)
    Set p2 = Application.InputBox("Chsoir la cellule de destination", , , , , , , 8)
    
    L = p.Rows.Count
    C = p.Columns.Count
    
    ReDim tablo(1 To C, 1 To L)
    ReDim tablo2(1 To C, 1 To 1)
    tablo = Application.Transpose(p)
    

    For j = 1 To L
        For i = 2 To C
            If Len(tablo(i, j)) <> 0 Then
                ReDim Preserve tablo2(1 To C, 1 To UBound(tablo2, 2) + 1)
                tablo2(i, UBound(tablo2, 2)) = tablo(i, j)
                tablo2(1, UBound(tablo2, 2)) = tablo(1, j)
            End If
        Next i
    Next j
    
p2.Cells(1, 1).Offset(-1, 0).Resize(UBound(tablo2, 2), UBound(tablo2, 1)) = Application.Transpose(tablo2)

End Sub

Sub InsereLignes2()
    Dim rg As Range
    Dim ColDonnees1 As Integer, ColDonnees2 As Integer
    Dim Nb As Integer, i As Integer, j As Integer
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    
    ColDonnees1 = 25    'colonne Y
    ColDonnees2 = 42    'colonne AP
    
    '1re cellule du tableau, adapter si nécessaire
    Set ws = ActiveSheet
    Set rg = ws.Range("A4")

    Do Until IsEmpty(rg)
        Nb = Application.CountA(Range(ws.Cells(rg.Row, ColDonnees1), ws.Cells(rg.Row, ColDonnees2)))

        If Nb > 1 Then
        'on doit insérer une ligne
            For i = 1 To Nb - 1
                rg.EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
                rg.Resize(1, ColDonnees1 - 1).Offset(-1, 0).FormulaR1C1 = rg.Resize(1, ColDonnees1 - 1).Offset(0, 0).FormulaR1C1
                For j = ColDonnees1 To ColDonnees2
                    If Cells(rg.Row, j) <> "" Then
                        Cells(rg.Row - 1, j) = Cells(rg.Row, j)
                        Cells(rg.Row, j) = ""
                        GoTo Prochain
                    End If
                Next j
Prochain:
            Next i
        End If
    
    
    Set rg = rg.Offset(1, 0)
    Loop
    
    Application.ScreenUpdating = True

End Sub

Sub InsereLignes3()
    Dim rg As Range
    Dim ColDonnees1 As Integer, ColDonnees2 As Integer
    Dim Nb As Integer, i As Integer, j As Integer
    Dim ws As Worksheet
    Dim rgC As Range, rgP As Range
    
    Application.ScreenUpdating = False
    
    ColDonnees1 = 25    'colonne Y
    ColDonnees2 = 42    'colonne AP
    
    '1re cellule du tableau, adapter si nécessaire
    Set ws = ActiveSheet
    Set rg = ws.Range("A4")

    Do Until IsEmpty(rg)
        Nb = Application.CountA(Range(ws.Cells(rg.Row, ColDonnees1), ws.Cells(rg.Row, ColDonnees2)))

        If Nb > 1 Then
        'on doit insérer une ligne
            For i = 1 To Nb - 1
                rg.EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
                Set rgC = rg.Resize(1, ColDonnees1 - 1)
                Set rgP = rg.Offset(-1, 0)
                rgC.Copy rgP
                For j = ColDonnees1 To ColDonnees2
                    If Cells(rg.Row, j) <> "" Then
                        Cells(rg.Row - 1, j) = Cells(rg.Row, j)
                        Cells(rg.Row, j) = ""
                        GoTo Prochain
                    End If
                Next j
Prochain:
            Next i
        End If
    
    
    Set rg = rg.Offset(1, 0)
    Loop
    
    Application.ScreenUpdating = True

End Sub