Mise en forme spécifique en tableau

Sub Macro1()
'
    With Sheets("base")
        fin = .Range("A" & .Rows.Count).End(xlUp).Row
        Debut = 2
        Numtab = 1
        i = 2
        While i <= fin
           
            If Cells(i, 2) <> Cells(i + 1, 2) Then
                Rows(1).Copy
                Rows(i + 1).Insert shift:=xlDown
                Rows(i + 1).Insert shift:=xlDown
               
                'Range("A" & Debut & ":G" & i).Select
                ActiveSheet.ListObjects.Add(xlSrcRange, Range("A" & Debut - 1 & ":G" & i), , xlYes).Name = "Tableau" & Numtab
                Debut = i + 3
                Numtab = Numtab + 1
                i = i + 3
                fin = fin + 2
            Else
                i = i + 1
            End If
        Wend
        .Rows(fin).Delete
    End With
End Sub

Sub a()
Dim i As Long, rng As Range
Set rng = Sheets("base").UsedRange
For i = rng.Count To 2 Step -1
    If rng.Cells(i, 2).Value <> rng.Cells(i - 1, 2).Value Then
        rng.Cells(i, 1).Resize(2).EntireRow.Insert
    End If
Next
Sheets("base").Rows("2:3").Delete
End Sub