Keep printing until all values in a column is printed out - Macro

Try this:
Change Sheet2 with the the name of the second sheet.

Sub Print10s()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, r As Long
Set sh1 = ThisWorkbook.ActiveSheet
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
r = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row
i = 1
sh1.PageSetup.PrintArea = "A1:A10"
With sh2
    Do While i <= r
        .Range("A1:A10").Value = sh1.Range("A" & i & ":A" & i + 9).Value
        sh2.PrintOut
        i = i + 10
    Loop
End With

End Sub

Hello itsmejan24,

Welcome to the Forum!

The macro below will automatically find the end of column "A" on "Sheet1". The contents of these cells will be copied into cell "A1:B10" on "Sheet2", printed out and then repeated until there is no more. Data

You can change the worksheet names from "Sheet1" and "Sheet2" to what you are actually using. Not sure if the cell addresses on "Sheet2" were a typo but "A1:B10" is twenty cells, not ten.

Add a new VBA module to your workbook then copy and paste the code below into it.

Sub CopyAndPrint()

    Dim DstRng As Range
    Dim DstWks As Worksheet
    Dim i As Long
    Dim n As Long
    Dim R As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim SrcRng As Range
    Dim SrcWks As Worksheet
    
        Set SrcWks = Worksheets("Sheet1")
        Set DstWks = Worksheets("Sheet2")
        
        Set SrcRng = SrcWks.Range("A1")
        Set DstRng = DstWks.Range("A1:B10")
        
            Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
            If RngEnd.Row < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcWks.Range(SrcRng, RngEnd)
            
            For R = 1 To SrcRng.Rows.Count Step 10
                Set Rng = SrcRng.Rows(R).Resize(10, 1)
                    For n = 1 To Rng.Rows.Count Step 2
                        i = i + 1
                        DstRng.Cells(i, 1) = Rng.Cells(n, 1)
                        DstRng.Cells(i, 2) = Rng.Cells(n + 1, 1)
                    Next n
                i = 0
                DstWks.PrintOut
                DstRng.ClearContents
            Next R
            
End Sub

Hello itsmejan24,

Here is the update to add a blank between the lines on "Sheet2". The added change is in bold.

Sub CopyAndPrint()

    Dim DstRng As Range
    Dim DstWks As Worksheet
    Dim i As Long
    Dim n As Long
    Dim R As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim SrcRng As Range
    Dim SrcWks As Worksheet
    
        Set SrcWks = Worksheets("Sheet1")
        Set DstWks = Worksheets("Sheet2")
        
        Set SrcRng = SrcWks.Range("A1")
        Set DstRng = DstWks.Range("A1:B10")
        
            Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
            If RngEnd.Row < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcWks.Range(SrcRng, RngEnd)
            
            For R = 1 To SrcRng.Rows.Count Step 10
                Set Rng = SrcRng.Rows(R).Resize(10, 1)
                    For n = 1 To Rng.Rows.Count Step 2
                        i = i + 1
                        DstRng.Cells(i, 1) = Rng.Cells(n, 1)
                        DstRng.Cells(i, 2) = Rng.Cells(n + 1, 1)
                        i = i + 1
                    Next n
                i = 0
                DstWks.PrintOut
                DstRng.ClearContents
            Next R
            
End Sub

Please mark the thread as solved

Try this

Sub Print10s()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, r As Long
Set sh1 = ThisWorkbook.ActiveSheet
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
r = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row
Dim c As Byte
sh1.PageSetup.PrintArea = "A1:B20"
With sh2
    .Range("A1:B20").Value = ""
    Do While i < r
        For c = 1 To 20 Step 2
            i = i + 1
            .Range("A" & c & ":B" & c).Value = sh1.Range("A" & i).Value
        Next
        sh2.PrintOut
    Loop
End With
End Sub