Please refer to attached worksheet.
I need a loop that will fill cells marked in yellow on sheet "PaySlip", with data read from sheet "All Dpts" starting at R4C2 and ending when col. C is blank. There are blank rows between R4 and R1111, because these deprtments as shown in Col A, shrink and expaned all the time. I need all in sheet "All Dpts" col. 2 read to "PaySlip" sheet in order to produce payslips for all workers.

All right, here's the macro:

Option Explicit
Sub PrintPayStubs()
Dim i As Long, lastrow As Long, MaxNum As Long
Dim CancelDate As Variant, RngNum As Range, RngClk As Range

CancelDate = Application.InputBox("What is the paydate?")
If CancelDate = False Or CancelDate = "" Then
MsgBox "No Date entered, aborting print routine..."
Exit Sub
End If

Sheets("Payslip").Activate
Sheets("Payslip").Range("G2").Value = CancelDate
lastrow = Sheets("All Dpts").Range("B" & Rows.Count).End(xlUp).Row
Sheets("All Dpts").Range("AG4:AG" & lastrow).FormulaR1C1 = "=IF(RC2="""",R[-1]C,R[-1]C+1)"
Set RngNum = Sheets("All Dpts").Range("AG4:AG" & lastrow)
Set RngClk = Sheets("All Dpts").Range("B4:B" & lastrow)

MaxNum = WorksheetFunction.Max(RngNum)

For i = 1 To MaxNum Step 6 'change maxnum to some small number to test short runs
Range("A4").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i, RngNum, 0))
Range("A21").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 1, RngNum, 0))
Range("A38").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 2, RngNum, 0))
Range("A55").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 3, RngNum, 0))
Range("A72").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 4, RngNum, 0))
Range("A89").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 5, RngNum, 0))
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Next i

Sheets("All Dpts").Columns("AG").ClearContents
End Sub

This macro inserts CLK numbers into the yellow cells, as you requested. The only way this works though is for each of the payslips to reach over and grab matching info from the All Dpts sheet with an INDEX/MATCH. I've adjusted this version to do that, including matching the formats of paystubs 2-6 to paystub 1. Also, all the text entries on paystub 1 flows to the other stubs, so you only need adjust stub1 to adjust them all!

I've added button to start the Print Paystubs process. The only thing NOT on the All Dpts sheet was PAY DATE... so I made the macro ask you for that at the beginning.

Also, you'll have to work with SICK LEAVE formulas, I couldn't figure out what you had in mind there with no sick leave examples in the data set.

Give it a look.

NOTE: If you want to test this macro on a shorter run of printouts, change this line of the code:

For i = 1 To MaxNum Step 6
... change "MaxNum" to some smaller number, like 12 or 18 to get the first 2 or 3 pages (it prints 6 per page). Be sure to set it back to "MaxNum" before you use it for real.

Repeat pages already printed.



Option Explicit
Sub PrintPayStubs()
Dim i As Long, lastrow As Long, MaxNum As Long
Dim CancelDate As Variant, RngNum As Range, RngClk As Range

CancelDate = Application.InputBox("What is the paydate?")
If CancelDate = False Or CancelDate = "" Then
MsgBox "No Date entered, aborting print routine..."
Exit Sub
End If

Sheets("Payslip").Activate
Sheets("Payslip").Range("G2").Value = CancelDate
lastrow = Sheets("All Dpts").Range("B" & Rows.Count).End(xlUp).Row
Sheets("All Dpts").Range("AG4:AG" & lastrow).FormulaR1C1 = "=IF(RC2="""",R[-1]C,R[-1]C+1)"
Set RngNum = Sheets("All Dpts").Range("AG4:AG" & lastrow)
Set RngClk = Sheets("All Dpts").Range("B4:B" & lastrow)

MaxNum = WorksheetFunction.Max(RngNum)

For i = 1 To MaxNum Step 6 'change maxnum to some small number to test short runs
Range("A4").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i, RngNum, 0))
Range("A21").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 1, RngNum, 0))
Range("A38").Value = WorksheetFunction.Index(RngClk, WorksheetFunction.Match(i + 2, RngNum, 0))
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Next i

Sheets("All Dpts").Columns("AG").ClearContents
End Sub

Don't wory about repeat print mentioned earlier I have sorted it out.
Thanks a mil Jerry.