Sub CopyA4D6()
  Dim rg As Range, c As Range
  Set c = Cells(Rows.Count, 1).End(xlUp).Offset(1)
  Do While c.Count < [a2]
    Set c = Union(c, c.Areas(c.Areas.Count).Cells(1).Offset(3))
  Loop
  [a4:d6].Copy c
End Sub

Const RANGE_ADDRESS = "A4:D6"

Sub Main()
    Dim n As Long
    n = Range("A2").Value
    
    Dim r1 As Range
    Set r1 = Range(RANGE_ADDRESS)
    
    Dim r2 As Range
    Select Case n
    Case 0
    Case 1
        Set r2 = r1
    Case Is > 1
        Set r2 = r1.Offset(r1.Rows.Count).Resize((n - 1) * r1.Rows.Count)
        r2.Insert Shift:=xlDown
        Set r2 = r1.Offset(r1.Rows.Count).Resize((n - 1) * r1.Rows.Count)
        r1.Copy r2
    End Select
    
    DeleteRest r1, r2.Row + r2.Rows.Count
End Sub

Sub DeleteRest(r1 As Range, yBeg As Long)
    Dim y As Long
    Dim a As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
        
    a = r1.Columns(1)
    For y = 1 To UBound(a, 1)
        dic.Item(a(y, 1)) = 0
    Next
    
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        a = .Range(.Cells(1, 1), .Cells(y, 1))
    End With
    
    y = yBeg
    Do
        If y > UBound(a, 1) Then Exit Do
        If Not dic.Exists(a(y, 1)) Then Exit Do
        y = y + 1
    Loop
    
    If yBeg < y Then
        Range(Cells(yBeg, 1), Cells(y - 1, r1.Column + r1.Columns.Count - 1)).Delete Shift:=xlUp
    End If
End Sub