Option Explicit
Public Sub Snakecols()
  UserForm1.Show
End Sub
Sub SnakeCols_test4()
'This is basically what is in the command button
'Hrows = 1            'specify number of heading rows
'Cols = 3             'specify number of cols to copy (add 1 for spacing)
'setts = 4            'specify number of sets per page
'rowspp = 50          'specify number of rows per page
'ptsize = 0           'specify pointsize, must be > 6 to change
  Application.Run "personal.xls!SnakeColsx", 1, 3, 4, 65, 0
End Sub
'--command button for userform1 ----.
'Private Sub CommandButton1_Click()
'  Dim V1 As Long, v2 As Long, v3 As Long, v4 As Long
'  V1 = Val(UserForm1.TextBox1)
'  v2 = Val(UserForm1.TextBox2)
'  v3 = Val(UserForm1.TextBox3)
'  v4 = Val(UserForm1.TextBox4)
'  v5 = Val(UserForm1.TextBox5)
'  Unload UserForm1
'  Call SnakeColsx(V1, v2, v3, v4)
'End Sub

Public Sub SnakeColsx(Optional hrows As Long, Optional cols As Long, _
   Optional setts As Long, Optional rowspp As Long, Optional ptsize As Long)
'David McRitchie  http://www.mvps.org/dmcritchie/excel/excel.htm snake columns
'  Current code is in http://www.mvps.org/dmcritchie/excel/snakecol.htm
'  Install on Tools menu for testing and production once have INPUTBOX
'  testing.xls module(snakey)  test with worksheet(snaketest)
Dim chunks As Long
Dim lastrow As Long
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim sett As Long, chunk As Long

'--set defaults if run by itself
If hrows = 0 Then hrows = 1   'Specify number of heading rows
If cols = 0 Then cols = 2     'Specify number of cols to copy
If setts = 0 Then setts = 4   'Specify number of sets per page
If rowspp = 0 Then rowspp = 53  'Specify number of rows per page
Dim lastcell
Dim srow As Long, scol As Long, srow2 As Long, scol2 As Long
Dim drow As Long, dcol As Long, col2
Dim maxpages As Long
Set lastcell = Cells.SpecialCells(xlLastCell)
lastrow = lastcell.Row     'lastrow was found for you
maxpages = 1

Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Copy the Heading Area
    srow = 1
    scol = 1
    srow2 = hrows
    scol2 = cols
    'srow , scol, srow2, scol2, drow, dcol, wsSource, wsNew
    Sheets(wsSource.Name).Select
    Range(Cells(1, 1), Cells(srow2, scol2)).Select
    Application.CutCopyMode = False
    Selection.Copy

'Paste heading areas into New Sheet and make boldface
    drow = 1     'destination row will be incremented
    dcol = 1     'destination column will be incremented
For sett = 1 To setts Step 1
    Sheets(wsNew.Name).Select
    Range(Cells(drow, dcol), Cells(drow, dcol)).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    dcol = dcol + cols
Next sett
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$" & hrows  'corrected 2002-12-29
        .PrintTitleColumns = ""
    End With
    Rows("$1:$" & hrows).Select  'corrected 2002-12-29
    Selection.Font.Bold = True


'Break into chunks and paste into New Sheet
    srow = srow + hrows
    scol = 1    'never changes
    dcol = 1
    drow = drow + hrows

chunks = Int((lastrow - hrows + rowspp - 1) / rowspp)
maxpages = Int((chunks + setts - 1) / setts)

For chunk = 1 To chunks Step 1
   If srow > lastrow Then GoTo done
   dcol = 1
   For sett = 1 To setts Step 1
      scol = 1
      srow2 = srow + rowspp - 1
      col2 = cols

    Sheets(wsSource.Name).Select
    Range(Cells(srow, scol), Cells(srow2, scol2)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(wsNew.Name).Select
    Range(Cells(drow, dcol), Cells(drow, dcol)).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

      dcol = dcol + cols
      srow = srow + rowspp
      Rows(srow).Select
      ActiveCell.PageBreak = xlManual
        ' Row(srow).PageBreak = xlManual    'xlcalculationmanual   in xl97
   Next sett
   drow = drow + rowspp
Next chunk
done:
   Cells.Select                          'Select ALL cells
   If ptsize > 6 Then Cells.Font.Size = ptsize  'new 2002-12-20
   Cells.EntireColumn.AutoFit
   Application.ScreenUpdating = True     'place at end when debugged
   Application.DisplayAlerts = True
   'Cells.EntireColumn.AutoFit

   MsgBox ("Print Preview will be invoked now, please adjust MARGINS. " _
      & "Goal is to have no more than " & maxpages & " pages.  " _
      & "You will be ready then to PRINT your New sheet, " _
      & "and then possibly rename or delete your New sheet.")
  
   ActiveSheet.PrintPreview
End Sub