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

Sub List表示データ転記()  'Bookmaker版 Ver1.01
On Error GoTo Sub01_Err
    Dim myArea As Object, r As Object, Spellcnt 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("spellbook").Select              'スペルブックシートを選択
'    Range("A10", ActiveCell.SpecialCells(xlLastCell)).Select  '10行目以下全選択＃（呪文一つのときA10〜BQ8となるため修正）
    Range("A10", "A65536").Select  '10行目以下全選択＃
    Selection.EntireRow.Delete                  '行削除
    
    If Spellcnt <= 0 Then
       GoTo Sub01_End                           '呪文数0件時、終了
    End If
    
    Range("8:9").Copy                           'コピー元（行数指定）を選択＃
    EndLine = 9 + Spellcnt * 2 - 2              'コピー先の最終行を算出＃
    If Spellcnt > 1 Then                        '一行のみの場合コピー不要
        Range("10:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃
    End If
    Application.CutCopyMode = False             'コピー元の選択表示を解除

    Application.Goto Range("A1"), True          'カーソル位置初期化（不要っぽ）
    Application.ScreenUpdating = True           '画面更新を復帰
 
 'Spellbookの参照�ｂﾉ値を転記
    Set rngA = Range("BP9")                     'セットする最初のセルを指定＃
    SbRow = 0                                   'rngAからの相対距離用ワーク
    i = 0
    
    '１０行より多い場合
    If Spellcnt > 10 Then
        For i = 0 To Spellcnt - 1 - 10 Step 10  '一度に１０行づつ処理
            rngA.Offset(SbRow, 0) = ListNo(i)
            rngA.Offset(SbRow + 2, 0) = ListNo(i + 1)
            rngA.Offset(SbRow + 4, 0) = ListNo(i + 2)
            rngA.Offset(SbRow + 6, 0) = ListNo(i + 3)
            rngA.Offset(SbRow + 8, 0) = ListNo(i + 4)
            rngA.Offset(SbRow + 10, 0) = ListNo(i + 5)
            rngA.Offset(SbRow + 12, 0) = ListNo(i + 6)
            rngA.Offset(SbRow + 14, 0) = ListNo(i + 7)
            rngA.Offset(SbRow + 16, 0) = ListNo(i + 8)
            rngA.Offset(SbRow + 18, 0) = ListNo(i + 9)
            SbRow = SbRow + 20                  '2行 * 10個分＃
        Next
    End If
    
    For i = i To (i + (Spellcnt - 1) Mod 10)    '端数or１０行以下の処理（Spellcnt=10のときi=0〜9となる）
        rngA.Offset(SbRow, 0) = ListNo(i)
        SbRow = SbRow + 2                       '2行置き＃
    Next
Sub01_End:
    Exit Sub
Sub01_Err:
    MsgBox "マクロ実行エラー" & Chr(13) & Err.Description 'エラーメッセージ表示
End Sub