✅【段組数を聞いて自動で段組み印刷用シートを作成するマクロ】

Sub 段組み印刷_ユーザー指定()

Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim lastRow As Long
Dim rowsPerColumn As Long
Dim i As Long
Dim numCols As Integer
Dim userInput As Variant

' ユーザーに段組数を入力させる
userInput = InputBox("段組み数を入力してください（例：2、3）", "段組み数の指定", 2)

' キャンセル or 空欄の場合は終了
If userInput = "" Then Exit Sub

' 数値でない、または1未満の数なら終了
If Not IsNumeric(userInput) Or Val(userInput) < 1 Then
MsgBox "有効な段組み数を入力してください。", vbExclamation
Exit Sub
End If

numCols = CInt(userInput)

' シート設定
Set srcSheet = ActiveSheet
Set destSheet = Worksheets.Add
destSheet.Name = "段組み印刷_" & numCols & "段"

' 元データの最終行
lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row

' 段ごとの行数を計算
rowsPerColumn = Application.Ceiling(lastRow / numCols, 1)

' 段組みにしてコピー（A列のみ対象。必要に応じて変更可）
For i = 0 To numCols - 1
srcSheet.Range("A" & 1 + i * rowsPerColumn & ":A" & WorksheetFunction.Min((i + 1) * rowsPerColumn, lastRow)).Copy
destSheet.Cells(1, i * 2 + 1).PasteSpecial xlPasteValues
Next i

' 印刷設定
With destSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
End With

MsgBox numCols & "段に分割して印刷用シートを作成しました。", vbInformation

End Sub