Clear many empty tables of data

**salmasaied** · 10-24-2016, 10:11 AM

Greetings to all
I have data in data sheet.range("A8:BF" & Last row)
I have, for example, in sheet SALRY number 400 fixed table and transfer data to it from the data sheet
Work requirements requires from time to time to change this number, for example, to 300 table

I want to clear all the empty tables that do not contain data
Attached example sample
Thanks advanced for help

**salmasaied** · 10-24-2016, 11:24 AM

Please Help

**salmasaied** · 10-24-2016, 07:19 PM

Please Help

**salmasaied** · 10-25-2016, 02:44 AM

Please help me in this topic

**salmasaied** · 10-26-2016, 11:19 AM

Any help in this topic please

**ikboy** · 10-27-2016, 12:42 AM

Try this:

Option Explicit

Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
Dim ar As Variant, br(), zc&, zr&, n&, i&, j&, k&, h%
Dim rng As Range, rng2 As Range, rng3 As Range, w()
w = Array("TOTAL", "Signatures(1)", "Signatures(2)", "Signatures(3)", "Signatures(4)", "Signatures(5)", "Total of the above")
With Sheets(1)
    zr = .[a1048576].End(3).Row
    ar = .[a8].CurrentRegion.FormulaR1C1
    zc = UBound(ar, 2)
End With
i = IIf((zr - 7) Mod 20, Int((zr - 7) / 20) + 1, Int((zr - 7) / 20))
ReDim br(1 To i * 27, 1 To zc + 1)
With Sheets(2)
    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 k = 0 To UBound(w)
                br(n + k + 1, 2) = w(k)
            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))
            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))
            End If
            n = n + 7
        End If
    Next
    If n > k Then
        Set rng = Union(rng, .Cells(k + 8, 1).Resize(n - k, zc + 1))
        For k = 0 To UBound(w)
            br(n + k + 1, 2) = w(k)
        Next
        Set rng2 = Union(rng2, .Cells(n + 8, 1).Resize(7, zc + 1))
        Set rng3 = Union(rng3, .Cells(n + 8, 1), .Cells(n + 14, 1))
    End If
    .Rows("35:1048576").Clear
    .[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
    rng3.EntireRow.RowHeight = .[a28].RowHeight
End With
Set rng = Nothing: Set rng2 = Nothing
Application.ScreenUpdating = 1
End Sub

**salmasaied** · 10-27-2016, 10:35 AM

My dear sir, ikboy
good greeting
Thank you very much to reply and thank your patience
I have tested the code sender and works more than excellent
take up your hat respect and appreciation for this wonderful effort

Allow me dear sir Here's the clarifications

In Example five rows between the tables
This is a special five rows signatures of Messrs specialists
I wanted the signal only is it the signatures of area

Regarding Clear serial numbers
I want to keep the last a complete table even if not completed data
In order to print a the workbook as required
In the sense that if the data transferred to the last table less than 20 statement
The rest are cleared serial numbers until end of the table

Regarding the row No. 34 "Total of the above"
The existence of this row down signatures last table nonessential for two reasons

*** the last table ends with the signatures of Messrs specialists
*** All tables here fixed .... I hope that the idea is clear
Thank you again for your attention.... wish you a happy life

**ikboy** · 10-29-2016, 02:04 AM

See is suitable for you or not?

Option Explicit

Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
Dim ar As Variant, br(), zc&, zr&, n&, i&, j&, k&, h%, MyCell As Range
Dim rng As Range, rng2 As Range, rng3 As Range, w()
w = Array("TOTAL", "Signatures(1)", "Signatures(2)", "Signatures(3)", "Signatures(4)", "Signatures(5)", "Total of the above")
With Sheets(1)
    zr = .[a1048576].End(3).Row
    ar = .[a8].CurrentRegion.FormulaR1C1
    zc = UBound(ar, 2)
End With
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)
With Sheets(2)
    Set MyCell = ActiveCell
    If .[b1048576].End(3).Row > 34 Then .Rows("35:" & .[b1048576].End(3).Row).Delete
    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 k = 0 To UBound(w)
                br(n + k + 1, 2) = w(k)
            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))
            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))
            End If
            n = n + 7
        End If
    Next
    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))
        For i = 0 To UBound(w)
            br(k + i - 1, 2) = w(i)
        Next
    End If
    .Rows("35:1048576").Clear
    .[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
    rng3.EntireRow.RowHeight = .[a28].RowHeight
    Rows(n + 6).Delete
End With
MyCell.Activate
Set rng = Nothing: Set rng2 = Nothing: Set MyCell = Nothing
Application.ScreenUpdating = 1
End Sub

**salmasaied** · 10-30-2016, 11:59 AM

My dear sir, ikboy
welcome
sorry for being late
We approached the goal killer
Regarding the five rows
This signatures that represent five rows fixed
And therefore must delete this line of code for multiple signatures as the example attached
Thanks advanced for help

w = Array("TOTAL", "Signatures(1)", "Signatures(2)", "Signatures(3)", "Signatures(4)", "Signatures(5)", "Total of the above")

**ikboy** · 11-01-2016, 12:01 AM

Try this:

Option Explicit

Private Sub Worksheet_Activate()
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
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)
w(0) = Array("TOTAL")
w(2) = Array("Signing", "Signing", "Signing", "Signing", "Signing")
w(3) = Array("Competent", "Head of accounts", "Head of personnel affairs", "Financial Director", "General Director")
w(4) = Array("SALMASAIED", "YasserKhalil", "ZZ", "ikboy", "Emblem of the Repubic ")
w(6) = Array("Total of above")
With Sheets(1)
    zr = .[a1048576].End(3).Row
    ar = .[a8].CurrentRegion.FormulaR1C1
    zc = UBound(ar, 2)
    .Range(.[a8], .[a1048576].End(3)).EntireRow.Delete
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)
wc(0) = Array(2)
rc = Array(0, 2, 3, 4, 6)
With Sheets(2)
    For i = 1 To zc + 1
        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(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
    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 > 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
    .Rows("35:1048576").Clear
    .[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.Interior.Color = 10921638
    rng3.EntireRow.RowHeight = .[a28].RowHeight
    rng4.MergeCells = True
    rng4.WrapText = True
    rng4.Interior.Color = 9737946
    For i = 7 To 10
        rng4.Borders(i).Weight = 3
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    rng6.Interior.Color = 10213316
    Rows(n + 6).Delete
End With
MyCell.Select
Set rng = Nothing: Set rng2 = Nothing: Set MyCell = Nothing
Application.ScreenUpdating = 1
End Sub

**salmasaied** · 11-01-2016, 09:45 AM

My dear sir, ikboy
welcome
Despite the difficulty of the code
I have learned a lot from you
With the implementation the code ... delete all the data from the data sheet
But I can not modification
A final attempt to this topic
I've added the abbreviated code in Example attached

Is it possible modification depending the following conditions
The first condition
If data transmitted from the data sheet is less than or equal to 20 statement
tables delete the rest of the beginning of row No. 34 to the last row in the workbook

Second condition
If data transmitted from the data sheet larger than 20 statement
delete the rest of the table after another table until the end of the workbook
With serial numbers from the Clear after another row with data until the last table
Thanks advanced for help
Kind regards

**ikboy** · 11-01-2016, 11:54 PM

Using your button:

Sub ClearZZ()
Application.ScreenUpdating = 0
With Sheets(2)
    .UsedRange.Offset(28, 0).Clear
    .Range(.[a8], Cells(27, .UsedRange.Columns.Count)).ClearContents
End With
Application.ScreenUpdating = 1
End Sub
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
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)
w(0) = Array("TOTAL")
w(2) = Array("Signing", "Signing", "Signing", "Signing", "Signing")
w(3) = Array("Competent", "Head of accounts", "Head of personnel affairs", "Financial Director", "General Director")
w(4) = Array("SALMASAIED", "YasserKhalil", "ZZ", "ikboy", "Emblem of the Repubic ")
w(6) = Array("Total of above")
With Sheets(1)
    zr = .[a1048576].End(3).Row
    ar = .[a8].CurrentRegion.FormulaR1C1
    zc = UBound(ar, 2)
    .Range(.[a8], .[a1048576].End(3)).EntireRow.Delete
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)
wc(0) = Array(2)
rc = Array(0, 2, 3, 4, 6)
With Sheets(2)
    For i = 1 To zc + 1
        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(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
    .Rows("35:1048576").Clear
    .[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.Interior.Color = 10921638
    rng7.Font.Size = 24
    rng7.Font.Bold = 1
    rng7.HorizontalAlignment = xlCenter
    rng3.EntireRow.RowHeight = 50
    rng4.MergeCells = True
    rng4.WrapText = True
    rng4.Interior.Color = 9737946
    For i = 7 To 10
        rng4.Borders(i).Weight = 3
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    rng6.Interior.Color = 10213316
    Rows(n + 6).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

**salmasaied** · 11-02-2016, 09:19 AM

My dear sir, ikboy
welcome
Thank you for your attention and patience you very much
Here are some modifications were conducted successfully
Simple Note after asking for permission
Before the end, please add a condition to delete the last row if the data ended at an integer number divisible by 20 without breaking Order a print the workbook
Thanks advanced for help
Kind regards

**salmasaied** · 11-02-2016, 07:24 PM

My dear sir, ikboy
welcome
Some modifications were conducted in the previous the attached
Please see it
Thanks advanced for help
Kind regards

**ikboy** · 11-02-2016, 09:10 PM

Glad to know you are modifying the codes, if still facing error. Please try to amend the following lines.
Delete line(10) w(4) = Array("SALMASAIED", "YasserKhalil", "ZZ", "ikboy", "Emblem of the Repubic ")
Change line(23) rc = Array(0, 2, 3, 4, 6) to rc = Array(0, 2, 3, 6)
Change line(106) Rows(n + 6).Delete to .Rows(.[b1048576].End(3).Row).Delete

**salmasaied** · 11-02-2016, 09:33 PM

My dear sir, ikboy
You are a great magician
My happiness is that I have the honor of your brother and dear friend
Who taught me characters I became a slave to him
Allow me first final addition
Thanks advanced for help

**salmasaied** · 11-02-2016, 10:41 PM

My dear sir, ikboy
Welcome
The end of each work .... and the end of this topic collection All tables
Add in Example formulas to collect tables
How you can add these formulas to automatically collect All tables
Is it possible to copy formats in the same sheet formats Source
Thanks advanced for help

**ikboy** · 11-03-2016, 12:48 AM

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

**salmasaied** · 11-03-2016, 08:57 AM

My dear sir, ikboy
Welcome
I have a problem page breaks, what is the way
How can insert a page break and set the the scope of the print area

It helps copied formats of the sheet to print the source worksheet format
I want to copy all the formats of the row when grabbed into salry sheet
the same, font, Column Width, Row Height ,font color, font name
Thanks advanced for help

**ikboy** · 11-03-2016, 11:27 PM

Print:

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)
Application.PrintCommunication = False
With Sheets(2)
    f = ""
    .ResetAllPageBreaks
    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
            .HPageBreaks.Add .Rows(k + 7)
            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 = 60
    For i = 7 To 10
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    .Rows(.[b1048576].End(3).Row).Delete
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(.[b1048576].End(3).Row, zc + 2)).Address
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = 0
End With
Application.PrintCommunication = True
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

**salmasaied** · 11-04-2016, 02:48 PM

My dear sir, ikboy
Best Regards
Thank you for a wonderful solution
Thank you for this wonderful effort
Thank you for your patience with me
Here's the code without debug message
wish you more progress and prosperity and happy life
I'm very pleased to meet you

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 = ""
    .ResetAllPageBreaks
    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
            .HPageBreaks.Add .Rows(k + 7)
            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 = 60
    For i = 7 To 10
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    .Rows(.[b1048576].End(3).Row).Delete
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(.[b1048576].End(3).Row, zc + 1)).Address
    .PageSetup.FitToPagesWide = 1
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

**salmasaied** · 11-04-2016, 08:46 PM

My dear sir, ikboy
welcome
Sorry to go back again
Sorry for the delay to a problem in my computer
I've added code to print workbook under the name "PRINT_ALL" will insert the code
to convert the numbers to ABC and place it in the required cells in the last table and Clear after printing
Is it possible to add it to operate automatically without putting it in a separate Module

I want to insert code to convert numbers to ABC down the last table directly in the two cells C & D
Thanks advanced for help

**salmasaied** · 11-04-2016, 08:57 PM

There is a problem in raising attachment

**ikboy** · 11-04-2016, 09:19 PM

Attachment not found.

**salmasaied** · 11-05-2016, 01:42 AM

My dear sir, ikboy
welcome
Please return to the Post No. 22
Thank you so much

**salmasaied** · 11-05-2016, 02:24 AM

My dear sir, ikboy
welcome
I do not know what is the reality of the problem
I think the problem lies in this line of code line(12)
Please delete the row No. 81 and noted the result
Thanks advanced for help

If Cells(lr, "AN") = 0 Then .Value = "فقط" & Texte1 & Stx1 & St2 Else _

**salmasaied** · 11-05-2016, 11:16 PM

My dear sir, ikboy
welcome
I managed to solve the problem and became PRINT_ALL code works wonderfully
To work must be merge cells A, B and C in the " Total " row and also in the row " Total of above "
Thanks advanced for help

**salmasaied** · 11-06-2016, 07:17 PM

My dear sir, ikboy
welcome
wish Please complete this topic
Thanks advanced for help

**ikboy** · 11-06-2016, 10:47 PM

Hi salmasaied,
Due to your code "PRINT_ALL" show up as garbled on my computer. And I don’t understand your language , if you sure it work for you. Please just remove “rem” form line 125 to activate call PRINT_ALL .

Option Explicit
Sub ClearZZ()
Application.ScreenUpdating = 0
With Sheets(2)
    .UsedRange.Offset(28, 0).Clear
    .Range(.[a8], Cells(27, .UsedRange.Columns.Count)).ClearContents
End With
Application.ScreenUpdating = 1
End Sub
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)(0) = "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 = ""
    .ResetAllPageBreaks
    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) = 1: 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 .[a1048576].End(3).Row > 34 Then .Rows("35:" & .[a1048576].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
            .HPageBreaks.Add .Rows(k + 7)
            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(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3)))
                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, Union(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3))))
                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, Union(.Range(.Cells(n, 1), .Cells(n, 3)), .Range(.Cells(n + 6, 1), .Cells(n + 6, 3))))
        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
    Debug.Print rng.Address(0, 0)
    Application.CutCopyMode = 0
    rng.EntireRow.RowHeight = .Rows(8).RowHeight
    rng7.Font.Size = 24
    rng7.Font.Bold = 1
    rng7.HorizontalAlignment = xlCenter
    rng3.EntireRow.RowHeight = 60: rng3.MergeCells = True
    For i = 7 To 10
    Next
    rng5.HorizontalAlignment = xlCenterAcrossSelection
    .Rows(.[a1048576].End(3).Row).Delete
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(.[a1048576].End(3).Row, zc + 1)).Address
    .PageSetup.FitToPagesWide = 1
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
Rem Call PRINT_ALL
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

**salmasaied** · 11-07-2016, 07:10 PM

My dear sir, ikboy
welcome
So sorry of what had happened in your computer
But the code "PRINT_ALL" works wonderfully
You are VIP Enjoying a wonderful intelligently
Thank you my dear friend on this creativity
wish you a happy life

**salmasaied** · 11-09-2016, 09:08 AM

My dear sir, ikboy
welcome
Please dear friend
In relation to column B will be hidden
I want to start signatures in cell C
How can the distribution of the spaces between the signatures for the general appearance
I have tried to make modifications but to no avail
Example without code "PRINT_ALL"
Thanks advanced for help

**ikboy** · 11-09-2016, 10:34 PM

If my code okay, you can remove line 112 "rem" for hidden column "B"

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, 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(0)(0) = "Total"
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)(0) = "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 = 1 & Chr(2) & 2
    .ResetAllPageBreaks
    For i = 3 To zc + 1
    f = f & Chr(2) & i
        a(i) = .Columns(i).ColumnWidth / 2 + j: j = j + .Columns(i).ColumnWidth
    Next
    b(1) = 3: j = j - a(3) * 2 - .Columns(i - 1).ColumnWidth / 2
    For i = 2 To 5
        b(i) = Application.Match(j / 4 * (i - 1) + a(3), a, 1)
    Next
    wc(0) = Split(f, Chr(2))
    wc(1) = Array(3, b(2), b(3), b(4), b(5))
    If .[a1048576].End(3).Row > 34 Then .Rows("35:" & .[a1048576].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
            .HPageBreaks.Add .Rows(k + 7)
            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(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3)))
                Set rng4 = .Range(.Cells(k + 5, 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, Union(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3))))
                Set rng4 = Union(rng4, .Range(.Cells(k + 5, 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, Union(.Range(.Cells(n, 1), .Cells(n, 3)), .Range(.Cells(n + 6, 1), .Cells(n + 6, 3))))
        Set rng4 = Union(rng4, .Range(.Cells(n + 4, 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
    rng.EntireRow.RowHeight = .Rows(8).RowHeight
    Union(rng3, rng7).Font.Size = 24
    Union(rng3, rng7).Font.Bold = 1
    rng7.HorizontalAlignment = xlCenter
    rng3.EntireRow.RowHeight = 60: rng3.MergeCells = True
    For i = 7 To 10
    Next
    .Rows(.[a1048576].End(3).Row).Delete
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(.[a1048576].End(3).Row, zc + 1)).Address
    .PageSetup.FitToPagesWide = 1
End With
MyCell.Select
Set rng = Nothing: Set rng2 = Nothing: Set MyCell = Nothing: Set rng3 = Nothing
Set rng4 = Nothing: Set rng6 = Nothing: Set rng7 = Nothing
Rem Call PRINT_ALL
Rem Columns(2).Hidden = True
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 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

**salmasaied** · 11-10-2016, 07:12 PM

My dear sir, ikboy
welcome
But until now, I do not know how to activate the PRINT_ALL code to run automatically
once the data transfer source of the sheet without button
Thanks advanced for help

**ikboy** · 11-10-2016, 09:05 PM

You can use call to do it.
From my code you can remove "Rem" that in front of call print_all to activate it.

From my MIS2
ikboy

**salmasaied** · 11-10-2016, 09:30 PM

My dear sir, ikboy
welcome
I've tested the latest modification
But There is a problem in signatures outside of the print range
Thanks advanced for help

**salmasaied** · 11-11-2016, 07:07 PM

My dear sir, ikboy
welcome
Please see the attached the previous
Thanks advanced for help

**ikboy** · 11-11-2016, 09:20 PM

Please correct the below lines:

113    .Rows(n + 6).Delete
114    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(n + 4, zc + 1)).Address

**salmasaied** · 11-12-2016, 07:26 AM

Thank you very much Mr. ikboy for this fascinating solution
Thank you very much for these great efforts
Thanks a lot for great and wonderful help
You're a great man
wish you a happy life

**salmasaied** · 11-18-2016, 04:40 PM

My dear sir, ikboy
welcome
Sorry for the inconvenience again
please I want to start signatures from the 4 row down the table
Because it has been added to the line in the code "PRINT_ALL"
I have tried to Some modifications, but to no avail
Thank you so much

**ikboy** · 11-21-2016, 08:18 AM

Please upload a template file.

**salmasaied** · 11-21-2016, 11:01 AM

My dear sir, ikboy
Kind regards

Thank you very very much for your interest in
been modified code "PRINT_ALL" to add two lines down the table
Please dear friend
Note me movement code would need a magic touch of genius to you dear friend
Signatures in order to start from the 4 row
with a mind to be in the center horizontally and vertically

Excuse me dear friend to my question about the re-code "PRINT_ALL" in Post No. 33
I mean you can merging your code with the code "PRINT_ALL" to give the print command directly instead of implementing the code on each Alone
Thanks advanced for help

**ikboy** · 11-21-2016, 11:08 PM

Amended in red for your reference.

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, rng6 As Range, rng7 As Range
Dim w(6), wc(1), rc(), a(), b(1 To 5)
rc = Array(0, 4, 5, 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(0)(0) = "Total"
w(4) = Array("Signing", "Signing", "Signing", "Signing", "Signing")
w(5) = Array("Competent", "Head of accounts", "Head of personnel affairs", "Financial Director", "General Director")
w(6) = w(0): w(6)(0) = "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 = 1 & Chr(2) & 2
    .ResetAllPageBreaks
    For i = 3 To zc + 1
    f = f & Chr(2) & i
        a(i) = .Columns(i).ColumnWidth / 2 + j: j = j + .Columns(i).ColumnWidth
    Next
    b(1) = 3: j = j - a(3) * 2 - .Columns(i - 1).ColumnWidth / 2
    For i = 2 To 5
        b(i) = Application.Match(j / 4 * (i - 1) + a(3), a, 1)
    Next
    wc(0) = Split(f, Chr(2))
    wc(1) = Array(3, b(2), b(3), b(4), b(5))
    If .[a1048576].End(3).Row > 34 Then .Rows("35:" & .[a1048576].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
            .HPageBreaks.Add .Rows(k + 7)
            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(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3)))
                Set rng4 = .Range(.Cells(k + 5, 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, Union(.Range(.Cells(k + 1, 1), .Cells(k + 1, 3)), .Range(.Cells(k + 7, 1), .Cells(k + 7, 3))))
                Set rng4 = Union(rng4, .Range(.Cells(k + 5, 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, Union(.Range(.Cells(n, 1), .Cells(n, 3)), .Range(.Cells(n + 6, 1), .Cells(n + 6, 3))))
        Set rng4 = Union(rng4, .Range(.Cells(n + 4, 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
    rng.EntireRow.RowHeight = .Rows(8).RowHeight
    Union(rng3, rng7).Font.Size = 24
    Union(rng3, rng7).Font.Bold = 1
    rng7.HorizontalAlignment = xlCenter
    rng3.EntireRow.RowHeight = 60: rng3.MergeCells = True
    For i = 7 To 10
    Next
    .Rows(.[a1048576].End(3).Row).Delete
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(n + 5, zc + 1)).Address
    .Columns(2).Hidden = True
    .PageSetup.FitToPagesWide = 1
End With
MyCell.Select
Set rng = Nothing: Set rng2 = Nothing: Set MyCell = Nothing: Set rng3 = Nothing
Set rng4 = 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 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

**salmasaied** · 11-22-2016, 06:12 PM

My dear sir, ikboy
Kind regards
The subject of the most important topics in my life
Thank you dear friend
wish you more happiness and progress
To the meeting in other works

Hybrid View