Copy and transfer data from a Main sheet to two sheets based on two conditions

Hi everyone
I have attached the following example " TEST" to make it more clear
It is excellent but very slow in dealing with large data so I need a faster solution using arrays If possible
I have data starting at row 8
I need to Copy and transfer data from a Main sheet to two sheets based on two conditions
For example
In Main sheet the column No. 31 the word "Yes" I want to copy columns from 1 : 5 with columns from 33 : 36
depending on the 31 column and transferred them to the " yes" sheet
and In Main sheet the column No. 32 the word "no" I want to copy columns from 1 : 5 with columns from 37 : 40
depending on the 32 column and transferred them to the " no" sheet
This has been achieved in the attached file "TEST2"
I need to insert six rows after each 30 names in two sheets (yes & no)
These rows will serve as totals and footer.
I have highlighted the points where I would like to insert the rows
if the remain items is less than 30 then to insert rows directly after them
During that process I would like to add some strings in these inserted lines
in the first inserted row To create the totals formulas and the formatting
in the second inserted row type : "Signature" in column B and in column D: "Signature" and in column H: "Signature"
in the third inserted row type : "Auditor" in column B and in column D: "Head of Accounts" and in column H: "General Manager"
in the six inserted row To create the previous totals and the formatting
With adjust the vertical and horizontal page breaks automatically
I hope the idea is clear and I hope a solution using arrays
The expected result in the two sheets result1 and result2
Please have a look at the examples
Your help is greatly appreciated
Thanks in advance

A faster alternative without using arrays:
- I have not used arrays but I expect that you may find that this solution is quicker than your current one
- You can test in the attached workbook with {CTRL} q
- I added lots of duplicate rows to Data Source to allow fuller testing
- headers not added in row 1
- total font has not been made bold
- no merged cells - avoid them when you want to use VBA - they cause too many problems
- TestNo duplicated from TestYes (I was too lazy to write a code to avoid the duplication )

How it works:
- DataFilter used on sheet source - filter for YES or NO
- copy all filtered rows together to other sheet (copy ALL columns)
- then delete columns not required
- insert the 6 rows
- add totals etc

Sub test()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Call TestYes
    Call TestNo
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub TestYes()
    Dim yes As Worksheet, no As Worksheet, source As Worksheet
    Dim rng As Range, rngYes As Range, rngNo As Range
    Dim lRow As Long, fRow As Long, rCount As Long, rMod As Integer
    Dim i As Long, c As Integer, x As Integer
    Dim cel As Range, cel1 As Range, cel2 As Range, addr1 As String, addr2 As String
    Dim myFormula As String
    Set yes = Sheets("YES"): Set no = Sheets("NO"): Set source = Sheets("Data Source")
    
    With source
        lRow = .Range("C" & .Cells.Rows.Count).End(xlUp).Row       '
        Set rng = .Range("A1:AN" & lRow)
        rng.AutoFilter Field:=31, Criteria1:="YES", Operator:=xlFilterValues
        rng.Copy
        yes.Range("A1").PasteSpecial (xlPasteColumnWidths)
        rng.Copy yes.Range("A1")
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
        
    With yes
                .Range(.Cells(1, 37), .Cells(1, 40)).EntireColumn.Delete
                .Range(.Cells(1, 6), .Cells(1, 32)).EntireColumn.Delete

'insert 6 rows every 30 rows
                fRow = .Range("A" & .Cells.Rows.Count).End(xlUp).End(xlUp).Row
                If fRow > 1 Then .Rows("1:" & fRow).Delete
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                lRow = (30 - lRow Mod 30) + lRow
                .Cells(lRow + 1, 1).Value = "Marker"
            For i = lRow + 1 - 30 To 31 Step -30
                .Cells(i, 1).Resize(6).EntireRow.Insert Shift:=xlDown
            Next i
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                
'add trimmings and totals
           For i = lRow To 1 Step -36
                If i <> 31 Then
                    x = 31
                Else
                    x = 30
                End If
                
                Set cel = .Cells(i, 5)
                Set cel1 = cel.Offset(-x)
                Set cel2 = cel.Offset(-1)
            'totals
                For c = 0 To 4
                    addr1 = cel1.Offset(, c).Address(0, 0)
                    addr2 = cel2.Offset(, c).Address(0, 0)
                    myFormula = "=sum(" & addr1 & ":" & addr2 & ")"
                    cel.Offset(, c).Formula = myFormula
                    If i > 60 Then
                        addr1 = .Cells(i - 36, 5).Offset(, c).Address(0, 0)
                        myFormula = "=" & addr1
                        .Cells(i - 31, 5).Offset(, c).Formula = myFormula
                        If c = 0 Then .Cells(i - 31, 2) = "Previous Total"
                    End If
                Next c
                     .Cells(i, 2) = "TOTAL"
                     .Cells(i + 1, 2) = "Signature"
                     .Cells(i + 1, 4) = "Signature"
                     .Cells(i + 1, 8) = "Signature"
                     .Cells(i + 2, 2) = "Auditor"
                     .Cells(i + 2, 4) = "Head of Accounts"
                     .Cells(i + 2, 8) = "General Manager"
              Next i
        .Cells(1, 1).EntireRow.Insert Shift:=xlDown
    End With
End Sub

Sub TestNo()
    Dim yes As Worksheet, no As Worksheet, source As Worksheet
    Dim rng As Range, rngYes As Range, rngNo As Range
    Dim lRow As Long, fRow As Long, rCount As Long, rMod As Integer
    Dim i As Long, c As Integer, x As Integer
    Dim cel As Range, cel1 As Range, cel2 As Range, addr1 As String, addr2 As String
    Dim myFormula As String
    Set yes = Sheets("YES"): Set no = Sheets("NO"): Set source = Sheets("Data Source")
    
    With source
        lRow = .Range("C" & .Cells.Rows.Count).End(xlUp).Row       '
        Set rng = .Range("A1:AN" & lRow)
        rng.AutoFilter Field:=32, Criteria1:="NO", Operator:=xlFilterValues
        rng.Copy
        no.Range("A1").PasteSpecial (xlPasteColumnWidths)
        rng.Copy no.Range("A1")
        source.Activate
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
        
    With no
                .Range(.Cells(1, 6), .Cells(1, 36)).EntireColumn.Delete

'insert 6 rows every 30 rows
                fRow = .Range("A" & .Cells.Rows.Count).End(xlUp).End(xlUp).Row
                If fRow > 1 Then .Rows("1:" & fRow).Delete
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                lRow = (30 - lRow Mod 30) + lRow
                .Cells(lRow + 1, 1).Value = "Marker"
            For i = lRow + 1 - 30 To 31 Step -30
                .Cells(i, 1).Resize(6).EntireRow.Insert Shift:=xlDown
            Next i
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                
'add trimmings and totals
           For i = lRow To 1 Step -36
                If i <> 31 Then
                    x = 31
                Else
                    x = 30
                End If
                
                Set cel = .Cells(i, 5)
                Set cel1 = cel.Offset(-x)
                Set cel2 = cel.Offset(-1)
            'totals
                For c = 0 To 4
                    addr1 = cel1.Offset(, c).Address(0, 0)
                    addr2 = cel2.Offset(, c).Address(0, 0)
                    myFormula = "=sum(" & addr1 & ":" & addr2 & ")"
                    cel.Offset(, c).Formula = myFormula
                    If i > 60 Then
                        addr1 = .Cells(i - 36, 5).Offset(, c).Address(0, 0)
                        myFormula = "=" & addr1
                        .Cells(i - 31, 5).Offset(, c).Formula = myFormula
                        If c = 0 Then .Cells(i - 31, 2) = "Previous Total"
                    End If
                Next c
                     .Cells(i, 2) = "TOTAL"
                     .Cells(i + 1, 2) = "Signature"
                     .Cells(i + 1, 4) = "Signature"
                     .Cells(i + 1, 8) = "Signature"
                     .Cells(i + 2, 2) = "Auditor"
                     .Cells(i + 2, 4) = "Head of Accounts"
                     .Cells(i + 2, 8) = "General Manager"
              Next i
        .Cells(1, 1).EntireRow.Insert Shift:=xlDown
    End With
End Sub

@ Kev - I'm especially interested in the page breaks - have you already addressed them in your code?

@Xladept - my solution has not yet gone that far. Wanted to offer OP alternative to arrays ..

@Joky

Please consider these suggestions for your page layout
1 Do you need the empty rows at top of page 1
2 Signatures better laid out one under the other (see picture) - can double row height to provide more space
3 You do not need to use merged cells to get the look you want
- they are best avoided because they are very inflexible and are a nuisance if you want to alter things later


Layout.jpg

@xladept

@ Kev - I'm especially interested in the page breaks

Generic code for page breaks every "X" rows (- here set to 36 as per OP example)

Sub PageBreak()
    Dim lRow As Long, ws As Worksheet
    Set ws = ActiveSheet
    break = 36
    ws.ResetAllPageBreaks
    lRow = ws.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    For i = break + 1 To lRow Step break
        ws.HPageBreaks.Add Before:=ws.Cells(i, 1)
    Next
End Sub

Hi Kev,

Thanks for that, I tried something similar but it didn't work on my 2010 - do you have code for the vertical break??

@xladept

This works with both 2010 and 2016

Sub PageBreak()

    Dim lRow As Long, ws As Worksheet
    Set ws = ActiveSheet
    
    ws.ResetAllPageBreaks
    
' fit to 1 page wide
    With ws.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
    End With
    
'break every 36 rows
    break = 36
    lRow = ws.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    For i = break + 1 To lRow Step break
        ws.HPageBreaks.Add Before:=ws.Cells(i, 1)
    Next
       
End Sub

This is what I had to do before it worked:

Sheets("results").PageSetup.FitToPagesWide = 1
ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
                ActiveWindow.View = xlNormalView

And, I had to be in page break view to get the HBreaks

That was your second "bump" posted within a few hours of your own previous post
bump 1 = 14 hours (post#02)
bump 2 = 10.5 hours (post#14)

bump2 puts you at the bottom of the queue

Thanks a lot for reply Mr. kev
The problem is that the original file contains many interconnected papers so it took a lot of time until I finished it
Anyway You should be honest with you... your solution is very very excellent
I need to adjust the points referred in your code only
Thanks advanced for help
Regards

I will try to get back to your thread later today

What does this mean?

Add a line to not copy and transfer data if one of the two conditions is not met or the two conditions are not met

Does it mean copy only if column 30 = YES AND column 31 = NO


31 = YES
32 = NO
COPY to sheet YES and sheet NO

31 = (empty)
32 = NO
DO NOT COPY

31 = YES
32 = (empty)
DO NOT COPY


31 = (empty)
32 = (empty)
DO NOT COPY

Is that not the same as....?

If 31 = YES copy to sheet YES

IF 32 = NO copy to sheet NO

Thanks a lot for reply Mr. kev
If cells the column number 31 and the column number 32 = empty do not copy
If any cell in column 31 = yes Copy to sheet YES
If any cell in column 31 = empty no Copy in sheet YES
If any cell in column 32 = no Copy to sheet NO
If any cell in column 32 = empty no Copy in sheet NO
Regards

Again I repeat. These are the only conditions required:
IF 31 = YES copy to sheet YES
IF 32 = NO copy to sheet NO
Everything else is irrelevant
If I am incorrect, you need to amend data filter conditions

- If you choose to amend anything you will need to do the same for both TestYes and TestNo
- Row 1 is the header row repeated at top of every sheet
- I was not sure what to do with first 5 rows so I ignored this and left top of sheet without blank rows - you can amend code to suit- yourself (- but remember Row 1 is the header row repeated at top of every sheet)
- Total rows row height now 30 and font is bold
- Borders put around around all values
- Borders removed in signature area - you may want to increase the height of these rows
- Page breaks inserted every 36 rows
- No merged cells introduced - create them yourself if you want them
- You need to amend the array containing Headers1 to 9 - simply type the headers in " " separated with a comma (both macros)

Attached is PDF showing results
Attached is workbook with working code
Run macro Test which runs TestYes and TestNo

I am away from my computer for 7 days - so I cannot help you until then

This is TestYes - TestNo is exactly the same except where references are to sheet "NO" and column 30

Sub TestYes()
    Dim yes As Worksheet, no As Worksheet, source As Worksheet
    Dim rng As Range
    Dim lRow As Long, break As Integer
    Dim i As Long, c As Integer, x As Integer, m As Long
    Dim cel As Range, cel1 As Range, cel2 As Range, addr1 As String, addr2 As String
    Dim myFormula As String
    Set yes = Sheets("YES"): Set no = Sheets("NO"): Set source = Sheets("Data Source")
    
    With source
        lRow = .Range("C" & .Cells.Rows.Count).End(xlUp).Row       '
        Set rng = .Range("A1:AN" & lRow)
        rng.AutoFilter Field:=31, Criteria1:="YES"
        rng.Copy
        yes.Range("A1").PasteSpecial (xlPasteColumnWidths)
        rng.Copy yes.Range("A1")
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
        
    With yes
                .Range(.Cells(1, 37), .Cells(1, 40)).EntireColumn.Delete
                .Range(.Cells(1, 6), .Cells(1, 32)).EntireColumn.Delete
                .Cells.RowHeight = 15
                .Cells.Font.Size = 10
'remove blank rows
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                On Error Resume Next
                    .Range("A1:A" & lRow).SpecialCells(xlBlanks).EntireRow.Delete
                On Error GoTo 0
'insert 6 rows every 30 rows
                lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
                m = lRow Mod 30
                If m <> 0 Then lRow = (30 - m) + lRow
                .Cells(lRow + 1, 1).Value = "Marker"

                For i = lRow + 1 - 30 To 1 Step -30
                    .Cells(i, 1).Resize(6).EntireRow.Insert Shift:=xlDown
                Next i
                           
'add trimmings and totals
           lRow = .Range("A" & .Cells.Rows.Count).End(xlUp).Row
           For i = lRow To 7 Step -36
                If i <> 31 Then
                    x = 31
                Else
                    x = 30
                End If
                
                Set cel = .Cells(i, 5)
                Set cel1 = cel.Offset(-x)
                Set cel2 = cel.Offset(-1)
            'totals
                For c = 0 To 4
                    addr1 = cel1.Offset(, c).Address(0, 0)
                    addr2 = cel2.Offset(, c).Address(0, 0)
                    myFormula = "=sum(" & addr1 & ":" & addr2 & ")"
                    cel.Offset(, c).Formula = myFormula
                    If i > 60 Then
                        addr1 = .Cells(i - 36, 5).Offset(, c).Address(0, 0)
                        myFormula = "=" & addr1
                        .Cells(i - 31, 5).Offset(, c).Formula = myFormula
                        If c = 0 Then .Cells(i - 31, 2) = "Previous Total"
                    End If
                Next c
            'text
                     .Cells(i, 2) = "TOTAL"
                     .Cells(i + 1, 2) = "Signature"
                     .Cells(i + 1, 4) = "Signature"
                     .Cells(i + 1, 8) = "Signature"
                     .Cells(i + 2, 2) = "Auditor"
                     .Cells(i + 2, 4) = "Head of Accounts"
                     .Cells(i + 2, 8) = "General Manager"
                     
              
            'borders
                    .Range("A" & i + 1, "I" & i + 4).Borders.LineStyle = xlNone
                    With .Range("A" & i - 31 & ":I" & i).Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
            'font
                    .Range("A" & i - 31 & ":I" & i - 31).Font.Bold = True
                    .Range("A" & i & ":I" & i).Font.Bold = True
            'row height
                    .Range("A" & i - 31).RowHeight = 30
                    .Range("A" & i).RowHeight = 30
                    
              Next i
                    .Range("A" & .Cells.Rows.Count).End(xlUp).ClearContents  'remove temporary "Marker"
                    .Rows("1:5").Delete     'tidy up rows not required
                    'header row
                    .Range("A1:I1") = Array("Header1", "Header2", "Header3", "Header4", "Header5", "Header6", "Header7", "Header8", "Header9")
    
            
   
            'print set up
                .Activate
                With ActiveSheet
                    .PageSetup.PrintTitleRows = "$1:$1"
                    .ResetAllPageBreaks
        
                    ' fit to 1 page wide
                        With .PageSetup
                            .Zoom = False
                            .FitToPagesWide = 1
                        End With
                        
                    'break every 36 rows
                        break = 36
                        lRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
                        For i = break + 1 To lRow Step break
                            .HPageBreaks.Add Before:=.Cells(i, 1)
                        Next
                    End With
    End With
            


End Sub

Headers at top of page

If you want row 6 to be the headers and rows 1 to 5 to contain other information printed on every page then (for both macros):
1 delete this line

.Rows("1:5").Delete

2 add code for what you need in rows 1 to 5

3 change this

.PageSetup.PrintTitleRows = "$1:$1"

to

.PageSetup.PrintTitleRows = "$1:$6"

4 change this

.Range("A1:I1") = Array("Header1", "Header2", "Header3", "Header4", "Header5", "Header6", "Header7", "Header8", "Header9")

to

.Range("A6:I6") = Array("Header1", "Header2", "Header3", "Header4", "Header5", "Header6", "Header7", "Header8", "Header9")

The code to print automatically

ActiveSheet.PrintOut

Thanks a lot for reply Mr. kev
I have tested this great code ... That's really wonderful solution
In fact I've learned a lot from you and will do my best to study this great code
The last point is now for me
During data copy, the data copy range remains selected
Other than that I can work quietly
To clarify .... Please have a look at the examples
Regards

During data copy, the data copy range remains selected

add this line after the paste:

application.cutcopymode = false

Thanks a lot Mr. kev for your patience and for great help all the time
Thank you very very much for your great support in this issue
I am just a learner and I have learned a lot and a lot from you
The words are not enough to say thank you for you Mr. kev
I also thank Mr. xladept for his great efforts from which I learned a lot
Best Regards

Mr. kev
Thank you very very much for this great help

Could do this at end of macro

yes.Activate
Range("A1").Select

Just leaves cell A1 selected
Same for other sheets

This look like a new requirement

It would be better to start a new thread with a new title "Excel database of Hotel Issues"
Attach a sample file showing what is typed into main sheet and what you would like to see in corresponding room sheet