Printing a Single Column in Multiple Columns

@Lori
Instead of using the macro you might consider using my method using a formula. See my comment of 23 June 2018 (at the bottom of this page).

I've never used a macro before, and this one worked exactly as stated for one column only. Could you highlight in a different colour the places required to increase the number of columns included in the wrap around?

Thanks Allen, worked great!

If anyone is interested in a more elaborate macro that prepares a long and narrow data range for printing may use the macro bellow.

Macro prompts user to define, if any, any header rows.

Sub paginate_for_print()

'Macro written 21/06/2014

'If user prefers to let an apparently empty column between the moved data, he can type a space
'in the first to the right empty cell, next to existing data, set that column to the desired width and run the macro
'As this macro is designed to limit the number of printed pages, it runs on a copy of the original sheet
'Original data sheet remains unaltered

' Variable definition
Dim sr As Long, er As Long, rh As Long, hpb As Long, r As Long
Dim sc As Integer, ec As Integer, cc As Integer, ans As Integer, he_rows As Integer, v_pbreaks As Integer
Dim tlt As String, msg As String, he_ro As String, head_to_rep As String
Dim cell As Variant

' Collection of used range limits and columns
With ActiveSheet.UsedRange
sr = .Row
sc = .Column
er = .Rows.Count + sr - 1
ec = .Columns.Count + sc - 1
cc = .Columns.Count
End With

' Initial message and choices for header rows
msg = "This macro will create a new sheet stacking data " + Chr(13)
msg = msg & "for printing purposes." & Chr(13)
msg = msg & "Data row height must be identical." & Chr(13) & Chr(13)
msg = msg + "Do you have any header rows?"
tlt = "Please answer the question..."
ans = MsgBox(msg, vbYesNoCancel + vbQuestion, tlt)

If ans = 2 Then
msg = "Cancel button selected Macro ends."
tlt = "Good choice!"
MsgBox msg, vbOKOnly + vbInformation, tlt
Exit Sub
End If

On Error Resume Next
If ans = 6 Then
msg = "Select header rows or cell/s within header rows."
tlt = "Please follow instructions..."
he_ro = Application.InputBox(msg, Default:=Rows(sr).Address, Title:=tlt, Type:=8).Address
he_rows = Range(he_ro).Rows.Count
head_to_rep = Range(Cells(sr, sc), Cells(sr + he_rows - 1, ec)).Address

If IsEmpty(he_ro) Then
tlt = "Wise decision..."
msg = "Cancel button selected Macro ends."
MsgBox msg, vbOKOnly + vbInformation, tlt
Exit Sub
End If
Else
he_rows = 0
End If

On Error GoTo errorhandling

' Control of identical data rows height (headers excluded)
rh = Range(Cells(sr + he_rows, 1), Cells(er, 1)).RowHeight
If IsNull(Range(Cells(sr + he_rows, 1), Cells(er, 1)).RowHeight) Then
For Each cell In Range(Cells(sr + he_rows, 1), Cells(er, 1))
If cell.RowHeight <> cell.Offset(1, 0).RowHeight Then
cell.Range("a1:a2").EntireRow.Select
msg = "Data row height in rows " & cell.Row & " and " & cell.Row + 1 & " is not identical. Macro stops."
tlt = "Correct the error and try again! "
MsgBox msg, vbOKOnly + vbCritical, tlt
Exit Sub
End If
Next
End If

' Control of existance of data that could be condensed for printing
Application.ScreenUpdating = False 'Accelerates macro execution

Sheets(ActiveSheet.Name).Copy after:=Sheets(ActiveSheet.Name)

ActiveWindow.View = xlPageLayoutView 'This is necessary to display the page breaks

If ActiveSheet.HPageBreaks.Count > 0 Then
hpb_r = ActiveSheet.HPageBreaks(1).Location.Row
Else
tlt = "No need to paginate..."
MsgBox "Sheet is short. Macro ends", vbOKOnly + vbExclamation, tlt
Application.DisplayAlerts = False
ActiveWindow.ActiveSheet.Delete 'Deleting created copy of the original sheet
Application.ScreenUpdating = True
Exit Sub
End If

ActiveWindow.View = xlNormalView

v_pbreaks = 0

' Main part of the macro
Do While Application.WorksheetFunction.CountA(Rows(hpb_r)) > 0
Range(Cells(hpb_r, sc), Cells(er, ec)).Cut Destination:=Cells(sr + he_rows, ec + 1)

' Repeating header rows
If ans = 6 Then
Range(head_to_rep).Copy Destination:=Cells(sr, ec + 1)
End If

' Establishing the same format
Range(Cells(sr, sc), Cells(sr, ec)).EntireColumn.Copy
Cells(1, sc).Offset(0, cc).Range("A1").PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

If ActiveSheet.VPageBreaks.Count > v_pbreaks And cc > 1 Then

' Inserting, if necessary, a vertical page break to keep the group of transferred data un-split on the same sheet
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=Cells(1, ec + 1)
v_pbreaks = v_pbreaks + 1
End If

sc = sc + cc
ec = ec + cc
Loop

' Comment any of the following two lines to fit your preference
' ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayGridlines = False

Application.ScreenUpdating = True

Range("a1").Select

Exit Sub

errorhandling:
msg = "Macro encountered either a non-adequate data input or an unexpected error" + Chr(10)
msg = msg + "Try to re-run checking original data and selections" + Chr(10)
msg = msg + "If the error persists, contact the programmer" + Chr(10) + Chr(10)
msg = msg + "Thomas Papavasiliou" + Chr(10)
msg = msg + "e-mail thpapavasiliou@yahoo.com"
MsgBox msg, vbOKOnly + vbCritical, "If I am still alive, I will answer."

End Sub

Here is a relatively simple formula if you don't want to use a macro or the bypass via Word.

If your list to print is in column A and you want to print it in 4 columns of 40 rows each, then enter this formula in B1:
=INDIRECT(ADDRESS(ROW()+40*COLUMN(A1),1))
Leave the cellpointer in B1 and extent your selection to range B1:D40, press F2 and Ctrl+Enter.
And voila there is your list to print.
Select it (A1:D40) and in the Print Dialog check the "Selection" option in the Print What frame.
You are ready to print.

If you want to change the number of rows, change 40 in ...ROW()+40... to the number you want. For 25 rows:
=INDIRECT(ADDRESS(ROW()+25*COLUMN(A1),1))
The number of columns depends simply on your selection.

There is no need to use another sheet. After printing you can delete the formulas and your sheet is back to what it was before.