Clear many empty tables of data

For formula:

Sub zz()
Application.ScreenUpdating = 0
If Sheets(1).[a1048576].End(3).Row = 6 Then Exit Sub
Dim ar As Variant, br(), zc&, zr&, n&, i&, ii&, j&, k&, h%, MyCell As Range, t As Variant, f$
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range
Dim w(6), wc(1), rc(), a(), b(1 To 5)
rc = Array(0, 2, 3, 6)
ar = [a28:ao28].FormulaR1C1
For Each t In ar
    f = f & Chr(2) & t
Next
w(0) = Split(Mid(f, 2), Chr(2))
w(2) = Array("Signing", "Signing", "Signing", "Signing", "Signing")
w(3) = Array("Competent", "Head of accounts", "Head of personnel affairs", "Financial Director", "General Director")
w(6) = w(0): w(6)(1) = "Total of above"
For i = 2 To UBound(w(0))
    If Len(w(0)(i)) Then w(6)(i) = "=r[-6]c"
Next
With Sheets(1)
    zr = .[a1048576].End(3).Row
    ar = .[a8].CurrentRegion.FormulaR1C1
    zc = UBound(ar, 2)
End With
ReDim a(1 To zc + 1)
i = IIf((zr - 7) Mod 20, Int((zr - 7) / 20) + 1, Int((zr - 7) / 20))
ReDim br(1 To i * 27 + UBound(w) + 1, 1 To zc + 1)
i = Int(UBound(br, 2) / 5)
With Sheets(2)
f = ""
    For i = 1 To zc + 1
    f = f & Chr(2) & i
        a(i) = .Columns(i).ColumnWidth / 2 + j: j = j + .Columns(i).ColumnWidth
    Next
    b(1) = 2: j = j - a(2) * 2
    For i = 2 To 5
        b(i) = Application.Match(j / 4 * (i - 1) + a(2), a, 1)
    Next
    b(5) = b(5) - 2
    wc(0) = Split(Mid(f, 2), Chr(2))
    wc(1) = Array(b(1), b(2), b(3), b(4), b(5))
    If .[b1048576].End(3).Row > 34 Then .Rows("35:" & .[b1048576].End(3).Row).Delete Else .Rows(28).Copy .Rows(34)
    If .[xfd7].End(1).Column > zc + 1 Then .Range(.Cells(1, zc + 2), .Cells(1, .[xfd7].End(1).Column)).EntireColumn.Delete
    Set MyCell = ActiveCell
    For i = 3 To UBound(ar)
        n = n + 1
        br(n, 1) = i - 2
        For j = 1 To UBound(ar, 2)
            br(n, j + 1) = ar(i, j)
        Next
        If (i - 2) Mod 20 = 0 Then
            For ii = 0 To UBound(rc)
                h = IIf(rc(ii) Mod 6, 1, 0)
                For j = 0 To UBound(wc(h))
                    br(rc(ii) + n + 1, wc(h)(j)) = w(rc(ii))(j)
                Next
            Next
            k = (i - 2) / 20 * 27
            If rng Is Nothing Then
                Set rng = .Cells(k - 19, 1).Resize(20, zc + 1)
                Set rng2 = .Cells(k + 1, 1).Resize(7, zc + 1)
                Set rng3 = Union(.Cells(k + 1, 1), .Cells(k + 7, 1))
                Set rng4 = .Range(.Cells(k + 5, b(5)), .Cells(k + 6, b(5) + 4))
                Set rng5 = .Range(.Cells(k + 3, b(5)), .Cells(k + 6, b(5) + 4))
                Set rng6 = .Range(.Cells(k + 5, b(5) - 1), .Cells(k + 5, 1))
                Set rng7 = .Range(.Cells(k + 2, 1), .Cells(k + 6, zc + 1))
            Else
                Set rng = Union(rng, .Cells(k - 19, 1).Resize(20, zc + 1))
                Set rng2 = Union(rng2, .Cells(k + 1, 1).Resize(7, zc + 1))
                Set rng3 = Union(rng3, .Cells(k + 1, 1), .Cells(k + 7, 1))
                Set rng4 = Union(rng4, .Range(.Cells(k + 5, b(5)), .Cells(k + 6, b(5) + 4)))
                Set rng5 = Union(rng5, .Range(.Cells(k + 3, b(5)), .Cells(k + 6, b(5) + 4)))
                Set rng6 = Union(rng6, .Range(.Cells(k + 5, b(5) - 1), .Cells(k + 5, 1)))
                Set rng7 = Union(rng7, .Range(.Cells(k + 2, 1), .Cells(k + 6, zc + 1)))
            End If
            n = n + 7
        End If
    Next
    If n < 22 Then GoSub less
    If n > k Then
        n = UBound(br) - 6: k = n - 6: i = n - 20
        Set rng = Union(rng, .Cells(i, 1).Resize(20, zc + 1))
        Set rng2 = Union(rng2, .Cells(n, 1).Resize(7, zc + 1))
        Set rng3 = Union(rng3, .Cells(n, 1), .Cells(n + 6, 1))
        Set rng4 = Union(rng4, .Range(.Cells(n + 4, b(5)), .Cells(n + 5, b(5) + 4)))
        Set rng5 = Union(rng5, .Range(.Cells(n + 2, b(5)), .Cells(n + 5, b(5) + 4)))
        Set rng6 = Union(rng6, .Range(.Cells(n + 4, b(5) - 1), .Cells(n + 4, 1)))
        Set rng7 = Union(rng7, .Range(.Cells(n + 1, 1), .Cells(n + 5, zc + 1)))
        For ii = 0 To UBound(rc)
            h = IIf(rc(ii) Mod 6, 1, 0)
            For j = 0 To UBound(wc(h))
                br(rc(ii) + n - 7, wc(h)(j)) = w(rc(ii))(j)
            Next
        Next
    End If
    .[a8].Resize(UBound(br), UBound(br, 2)) = br
    .[a8].Resize(1, zc + 1).Copy: rng.PasteSpecial Paste:=xlPasteFormats
    .[a28].Resize(7, zc + 1).Copy: rng2.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = 0
    rng7.Font.Size = 24
    rng7.Font.Bold = 1
    rng7.HorizontalAlignment = xlCenter
    rng3.EntireRow.RowHeight = 50
    For i = 7 To 10
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    .Rows(.[b1048576].End(3).Row).Delete
End With
MyCell.Select
Set rng = Nothing: Set rng2 = Nothing: Set MyCell = Nothing: Set rng3 = Nothing
Set rng4 = Nothing: Set rng5 = Nothing: Set rng6 = Nothing: Set rng7 = Nothing
Application.ScreenUpdating = 1
End
less:
With Sheets(2)
    Set rng = .Cells(8, 1).Resize(20, zc + 1)
    Set rng2 = .Cells(28, 1).Resize(7, zc + 1)
    Set rng3 = Union(.Cells(28, 1), .Cells(34, 1))
    Set rng4 = .Range(.Cells(32, b(5)), .Cells(33, b(5) + 4))
    Set rng5 = .Range(.Cells(30, b(5)), .Cells(33, b(5) + 4))
    Set rng6 = .Range(.Cells(32, b(5) - 1), .Cells(32, 1))
    Set rng7 = .Range(.Cells(29, 1), .Cells(33, zc + 1))
End With
Return
End Sub