'呪文listのソート（並び替え）は事前に自分でやっておくこと。（レベル順にするなら並び替え必須）
'レイアウトなど変更時は、コメント欄に＃がついてるあたりをチェックするといいかも。
'Spellbookシートは8,9行目を元に毎回書き直しているので、見栄えを良くするために変更している場合はがんばれ。
Option Explicit

Sub List表示データ転記()   'Cardmaker版 Ver1.01
'On Error GoTo Sub01_Err
    Dim myArea As Object, r As Object, Spellcnt As Integer, Setcnt As Integer, SbRow As Long
    Dim y1 As Long, y2 As Long, yy As Long, i As Integer, EndLine As Integer
    Dim rngA As Range
    Dim ListNo() As Integer                     '番号記憶用配列宣言
    Application.ScreenUpdating = False          '画面の更新を行わない
    
 '表示行を全て選択
    Worksheets("list").Activate                 'リストシートをアクティブにする
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
 
 '行数算出
    For Each myArea In Selection.Areas          '各領域ごとに行数を取得して加算する
        Spellcnt = Spellcnt + myArea.Rows.Count
    Next
    Spellcnt = Spellcnt - 1                     '見出し行を除くため「1」減算
 
 '警告メッセージ表示（警告件数は てきとー
    If Spellcnt > 500 Then                      '警告件数チェック
        If 1 <> MsgBox("データが多いため時間がかなりかかります。" & Chr(13) & "このまま続けますか？" & _
                        Chr(13) & "（続行後、途中で止めたくなったら「CTRL＋Break」）", 17, "警告") Then
            GoTo Sub01_End
        End If
    End If
 
 '選択中のリスト�ｂ�配列へ保存
    ReDim ListNo(0 To Spellcnt)
    i = 0
    For Each myArea In Selection.Areas          '各領域ごとに値を取得して配列へセット
        y1 = myArea.Rows.Row                    '選択範囲ii番目の上端行番号
        y2 = myArea.Rows(myArea.Rows.Count).Row '選択範囲ii番目の下端行番
        For yy = y1 To y2
            If yy <> 1 Then
                ListNo(i) = Cells(yy, 1).Value
                i = i + 1
            End If
        Next
    Next
                   
 'SpellBook初期化（最初の２〜２６行を必要な回数コピー）
    Worksheets("spellcard_maker").Select        'spellcard_makerシートを選択
'    Range("A27", ActiveCell.SpecialCells(xlLastCell)).Select  '２７行目以下全選択＃（呪文３つ以下でセーブ時A27〜BQ24となるため）
    Range("A27", "A65536").Select  '２７行目以下全選択＃
    Selection.EntireRow.Delete                  '行削除
    
    If Spellcnt <= 0 Then
       GoTo Sub01_End                           '呪文数0件時、終了
    End If
    
    Range("2:26").Copy                          'コピー元（行数指定）を選択＃
    If Spellcnt Mod 3 = 0 Then                  '３つ１セットとして何セット必要か？＃
       Setcnt = Int(Spellcnt / 3)
    Else
       Setcnt = Int(Spellcnt / 3) + 1
    End If
    EndLine = 26 + (Setcnt - 1) * 25            'コピー先の最終行を算出＃
    If Setcnt > 1 Then                          '３つ以下の場合コピー不要
        Range("27:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃
    End If
    Application.CutCopyMode = False             'コピー元の選択表示を解除

    Application.Goto Range("A1"), True          'カーソル位置初期化（不要っぽ）
    Application.ScreenUpdating = True           '画面更新を復帰
 
 'Spellbookの参照�ｂﾉ値を転記
    Set rngA = Range("L24")                     'セットする最初のセルを指定＃
    SbRow = 0                                   'rngAからの相対距離用ワーク
    i = 0
    
    '３以上の場合
    If Spellcnt >= 3 Then
        For i = 0 To (Spellcnt - (Spellcnt Mod 3) - 3) Step 3   '一度に１行(３つ)づつ処理
            rngA.Offset(SbRow, 0) = ListNo(i)       '左
            rngA.Offset(SbRow, 13) = ListNo(i + 1)  '中央
            rngA.Offset(SbRow, 26) = ListNo(i + 2)  '右
            SbRow = SbRow + 25                  '3個/25行 ＃
        Next
    End If
    
    '端数or２つ以下の処理
    Select Case (Spellcnt Mod 3)
       Case 1
           rngA.Offset(SbRow, 0) = ListNo(i)       '左
           rngA.Offset(SbRow, 13) = ""             '中央
           rngA.Offset(SbRow, 26) = ""             '右
       Case 2
           rngA.Offset(SbRow, 0) = ListNo(i)       '左
           rngA.Offset(SbRow, 13) = ListNo(i + 1)  '中央
           rngA.Offset(SbRow, 26) = ""             '右
    End Select
Sub01_End:
    Exit Sub
Sub01_Err:
    MsgBox "マクロ実行エラー" & Chr(13) & Err.Description 'エラーメッセージ表示
End Sub