串刺し印刷するための、串刺し処理（串刺し面付）
2022/10/15
----- べんりあつめ。-----
A列は関係ないけど、B列にサイズが入っていて、C列に串刺し番号を vba で表示するっていうのが↓
Sub 串刺し印刷()
'┌──────────────────────────┐
'特定列の最終行
Dim MaxRow As Long
MaxRow = Cells(Rows.Count, 2).End(xlUp).Row
'└──────────────────────────┘
'B列で並び替え処理がここで必要かも
'┌──────────────────────────┐
'宣言
Dim iKus: iKus = 1 'A 処理時の行番号
Dim cTop, cUnder 'A 上のセルのサイズ、下のセルのサイズ
Dim cnt 'A 同じサイズの個数
Dim cntOld: cntOld = 0 'B 同じサイズの個数処理のひとつ前の個数
Dim menCnt 'C 面付け数
Dim maxPage 'D 最大ページ数
Dim maxPageOld 'D 前回の最大ページ数
'└──────────────────────────┘
'項目名
Cells(1, 3) = "串刺し番号"
'┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓
'串刺し番号の入力処理
For iii = 2 To MaxRow
'┌──────────────────────────┐
'【A】 同じサイズの個数を調べる
cnt = 0
Do
iKus = iKus + 1 '2行目からスタート
cTop = Cells(iKus, 2)
cUnder = Cells(iKus + 1, 2)
cnt = cnt + 1
Loop While cTop = cUnder
'└──────────────────────────┘
'┌──────────────────────────┐
'【B】 同じサイズの個数処理対応
'cnt = cnt - cntOld
cntOld = cnt + cntOld
'└──────────────────────────┘
'┌──────────────────────────┐
'【C】 サイズで１ページの面付数の決定（サイズ別の面付け数を入力必須）■■■■■■■■■■■■■■■
Select Case cTop
'A--------------
Case Is = "A"
menCnt = 12
'B--------------
Case Is = "B"
menCnt = 6
'C--------------
Case Is = "C"
menCnt = 3
'---------------
Case Else
End Select
'└──────────────────────────┘
'┌──────────────────────────┐
'【D】 最大枚数
maxPage = Application.WorksheetFunction.RoundUp(cnt / menCnt, 0)
'└──────────────────────────┘
'┌──────────────────────────┐
'【E】 串刺し番号にページ数を入力
'ページ数初期値
ii = 1
'同じサイズの個数cntの数だけ処理
For i = 1 To cnt
'最大枚数を超えた場合は１に戻す
If ii > maxPage Then
ii = 1
Else
End If
'ページ番号を入力
Cells(i + 1 + iOld, 3) = ii + maxPageOld
'ページ番号を増やしておく
ii = ii + 1
Next
'└──────────────────────────┘
iOld = i + iOld - 1
maxPageOld = maxPage + maxPageOld
iii = iOld + 1
Next
'┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛
'┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓
'並び替えをするかどうか確認する
'MsgBox 「はい」「いいえ」のダイアログボックス
'「はい」「いいえ」処理
Dim Qmsg As Integer
Qmsg = MsgBox("並び替えまでしますか？", vbYesNo + vbExclamation + vbDefaultButton2, "処理判断")
If Qmsg = 6 Then
'クリックされたボタンが「はい」＝６の場合
'■■■■■■■「はい」の処理
'==========================================================
'■並べ替え
'必須の条件クリア
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
'並べ替えの条件設定
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("C1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
' Key 並べ替えのキー
' SortOn 並べ替えの種別（値・背景色・文字色・アイコン）
' Order 昇順（xlAscending）・降順（xlDescending）
' DataOption 数値と文字列数値が混在しても同様に並び替える xlSortTextAsNumbers
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A1:EX50000")
.Header = xlYes '先頭行は見出しと認識して除外
.MatchCase = False '大文字小文字は区別しない
.Orientation = xlTopToBottom '行で並び替えする 列で並び替えする時は xlLeftToRight
.SortMethod = xlStroke 'ふりがなを無視する
.Apply '以上の条件で並び替え実行
End With
'必須の条件クリア
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
'===========================================================
Else
'■■■■■■■■「いいえ」の処理
Exit Sub
End If
'┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛
End Sub