Macro that makes two pages for printing from one row

[petars87]

Hi people,

need your help with these:

i will like to make macro that copy data from sheet1 to sheet2(on this forum i learned how to do that) and also to format data on sheet2 like in example down:


sheet1:

	A	B	C	D	E	F	G	H	I	J
1	NAME	COL1	COL2	COL3	COL4	COL5	COL6	COL7	COL8	COL9
2	Petar	1	2	3	4	5	6	7	8	9
3	John	20	36	40	50	60	70	80	90	100
...	...	...	...

<tbody>
</tbody>

in sheet1 i can have n rows and from every row to make like in example down:

sheet2:

	A	B
1	sheet1 A2	sheet1 B2
2	sheet1 C2	sheet1 D2
3	sheet1 E2	sheet1 F2
4	sheet1 G2	sheet1 H2
5	sheet1 I2	sheet1 J2
6	sheet1 A3	sheet1 B3
7	sheet1 C3	sheet1 D3
8	sheet1 E3	sheet1 F3
9	sheet1 G3	sheet1 H3
10	sheet1 I3	sheet1 J3
...	...	...

<tbody>
</tbody>

i will like to copy till last row in sheet1 and i will like to format every this set of data(every five rows in sheet2) to be ready for printing like document with two pages where first 3 rows is page 1(red color) and 4th and 5th row are page 2.

Thank you guys!

 

[Warship]

Sub CollectData()
    Dim sourceSheet As Worksheet
    Dim destinSheet As Worksheet
    Dim lastRow As Long, r As Long, c As Integer
    Dim dR As Long, dC As Integer
    Application.ScreenUpdating = False
    Set sourceSheet = Sheets("Sheet1")
    Set destinSheet = Sheets("Sheet2")
    destinSheet.Cells.Clear
    lastRow = sourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
    dR = 1
    dC = 1
    For r = 2 To lastRow
        For c = 1 To 10
            destinSheet.Cells(dR, dC) = sourceSheet.Cells(r, c)
            Select Case c
                Case 1 To 6
                    destinSheet.Cells(dR, dC).Font.Color = vbRed
                Case 7 To 10
                    destinSheet.Cells(dR, dC).Font.Color = vbGreen
            End Select
            If dC = 1 Then
                dC = 2
            Else
                dC = 1
                dR = dR + 1
            End If
        Next c
    Next r
End Sub

Sub PrintData()
    Dim printSheet As Worksheet
    Dim prArea As Range
    Set printSheet = Sheets("Sheet2")
    Set prArea = printSheet.Range("A1:B3")
    printSheet.PageSetup.PrintArea = prArea.Address
    Do
        printSheet.PrintOut
        If prArea.Rows.Count = 3 Then
            Set prArea = prArea.Offset(3).Resize(2, 2)
        Else
            Set prArea = prArea.Offset(2).Resize(3, 2)
        End If
        printSheet.PageSetup.PrintArea = prArea.Address
    Loop Until prArea.Cells(1, 1) = ""
End Sub