'PowerListのソート（並び替え）は事前に自分でやっておくこと。
'レイアウトなど変更時は、コメント欄に＃がついてるあたりをチェックするといいかも。
'maker3シートは一番上の３枚を元に毎回書き直しているので、見栄えを良くするために変更している場合はがんばれ。
Option Explicit

Sub List表示データ転記()   'Psi_Cardmaker版 Ver1.00
'On Error GoTo Sub01_Err
    Dim myArea As Object, r As Object, Powercnt 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("PowerList").Activate                 'リストシートをアクティブにする
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
 
 '行数算出
    For Each myArea In Selection.Areas          '各領域ごとに行数を取得して加算する
        Powercnt = Powercnt + myArea.Rows.Count
    Next
    Powercnt = Powercnt - 1                     '見出し行を除くため「1」減算
 
 '警告メッセージ表示（警告件数は てきとー
    If Powercnt > 500 Then                      '警告件数チェック
        If 1 <> MsgBox("データが多いため時間がかなりかかります。" & Chr(13) & "このまま続けますか？" & _
                        Chr(13) & "（続行後、途中で止めたくなったら「CTRL＋Break」）", 17, "警告") Then
            GoTo Sub01_End
        End If
    End If
 
 '選択中のリスト�ｂ�配列へ保存
    ReDim ListNo(0 To Powercnt)
    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
                   
 'PowerList初期化（最初の２〜２４行を必要な回数コピー）
    Worksheets("maker3").Select                 'Psicard_makerシートを選択
    Range("A25", "A65536").Select               '２５行目以下全選択＃
    Selection.EntireRow.Delete                  '行削除
    
    If Powercnt <= 0 Then
       GoTo Sub01_End                           'パワー数0件時、終了
    End If
    
    Range("1:24").Copy                          'コピー元（行数指定）を選択＃
    If Powercnt Mod 3 = 0 Then                  '３つ１セットとして何セット必要か？＃
       Setcnt = Int(Powercnt / 3)
    Else
       Setcnt = Int(Powercnt / 3) + 1
    End If
    EndLine =  Setcnt * 24                      'コピー先の最終行を算出＃
    If Setcnt > 3 Then                          '３つ以下の場合コピー不要
        Range("25:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃
    End If
    Application.CutCopyMode = False             'コピー元の選択表示を解除

    Application.Goto Range("A1"), True          'カーソル位置初期化（不要っぽ）
    Application.ScreenUpdating = True           '画面更新を復帰
 
 'PowerListの参照�ｂﾉ値を転記
    Set rngA = Range("L23")                     'セットする最初のセルを指定＃
    SbRow = 0                                   'rngAからの相対距離用ワーク
    i = 0
    
    '３以上の場合
    If Powercnt >= 3 Then
        For i = 0 To (Powercnt - (Powercnt 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 + 24                  '3個/24行 ＃
        Next
    End If
    
    '端数or２つ以下の処理
    Select Case (Powercnt 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