Segue conforme pedido:

Option Explicit

Sub Add_Rows()
Dim ul, i, qtd_linhas As Long
Dim ws As Worksheet
Dim cel As Variant
Dim tabela As Range

Application.ScreenUpdating = False

Set ws = Sheets("BASE")
Set tabela = ws.Range("B4").CurrentRegion

qtd_linhas = 1 'QUANTIDADE DE LINHAS A ADICIONAR | MUDE SE NECESSÁRIO

With tabela
   .Borders(xlDiagonalDown).LineStyle = xlNone
   .Borders(xlDiagonalUp).LineStyle = xlNone
   .Borders(xlEdgeLeft).LineStyle = xlNone
   .Borders(xlEdgeTop).LineStyle = xlNone
   .Borders(xlEdgeBottom).LineStyle = xlNone
   .Borders(xlEdgeRight).LineStyle = xlNone
   .Borders(xlInsideVertical).LineStyle = xlNone
   .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

inicio:
ul = ws.Range("G" & Rows.Count).End(xlUp).Row

    For Each cel In ws.Range("G3:G" & ul)
        If cel.Value <> cel.Offset(1, 0).Value And _
                       cel.Offset(1, 0).Value <> "" _
                       And cel.Value <> "" Then
                       For i = 1 To qtd_linhas
                            cel.Offset(1, 0).EntireRow.Insert _
                            Shift:=xlDown
                            ws.Range("A" & cel.Offset(1, 0).Row & ":j" & cel.Offset(1, 0).Row).Interior.ColorIndex = _
                            ws.Range("A" & cel.Offset(2, 0).Row & ":j" & cel.Offset(2, 0).Row).Interior.ColorIndex
                       Next i
                       GoTo inicio
        End If
            
    Next

For i = 4 To ul
    If ws.Range("B" & i).Value <> "" Then
        With ws.Range("B" & i & ":J" & i).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ws.Range("B" & i & ":J" & i).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ws.Range("B" & i & ":J" & i).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ws.Range("B" & i & ":J" & i).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ws.Range("B" & i & ":J" & i).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ws.Range("B" & i & ":J" & i).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    End If
    
Next i


Set ws = Nothing
Set tabela = Nothing
Application.ScreenUpdating = True

End Sub

Sub Delete_Rows()
Dim ul As Long
Dim ws As Worksheet
Dim cel As Variant

Set ws = Sheets("BASE")

inicio:
ul = ws.Range("G" & Rows.Count).End(xlUp).Row

    For Each cel In ws.Range("B4:B" & ul)
        If cel.Value = "" Then
            cel.EntireRow.Delete
            GoTo inicio
        End If
            
    Next

Set ws = Nothing

End Sub

Perfeito xlarruda.
Muitíssimo Obrigado