'呪文listのソート（並び替え）は事前に自分でやっておくこと。（レベル順にするなら並び替え必須） 'レイアウトなど変更時は、コメント欄に＃がついてるあたりをチェックするといいかも。 'Spellbookシートは３〜５行目を元に毎回書き直しているので、見栄えを良くするために変更している場合はがんばれ。 Option Explicit '各マクロ共通　ワークシート名定数設定 Const strリストシート As String = "ｌｉｓｔ" 'Listワークシート名 Const strスペルシート As String = "Spellbook_maker" 'SpellListワークシート名 Const strカードシート As String = "spellcard_maker" 'SpellCardワークシート名 Sub ListToSpellList() 'Bookmaker版 Ver3.5 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(strリストシート).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(strスペルシート).Select 'スペルブックシートを選択 ' Range("A10", ActiveCell.SpecialCells(xlLastCell)).Select '10行目以下全選択＃（呪文一つのときA10〜BQ8となるため修正） Range("A7", "A65536").Select '10行目以下全選択＃ Selection.EntireRow.Delete '行削除 If Spellcnt <= 0 Then GoTo Sub01_End '呪文数0件時、終了 End If Range("3:5").Copy 'コピー元（行数指定）を選択＃ EndLine = 2 + Spellcnt * 3 - 3 'コピー先の最終行を算出＃ If Spellcnt > 1 Then '一行のみの場合コピー不要 Range("6:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃ End If Application.CutCopyMode = False 'コピー元の選択表示を解除 Application.Goto Range("A1"), True 'カーソル位置初期化（不要っぽ） Application.ScreenUpdating = True '画面更新を復帰 'Spellbookの参照ｂﾉ値を転記 Set rngA = Range("BK3") 'セットする最初のセルを指定＃ SbRow = 0 'rngAからの相対距離用ワーク i = 0 '１０行より多い場合 If Spellcnt > 10 Then For i = 0 To Spellcnt - 1 - 10 Step 10 '一度に１０行づつ処理 rngA.Offset(SbRow + 1, 0) = ListNo(i) rngA.Offset(SbRow + 4, 0) = ListNo(i + 1) rngA.Offset(SbRow + 7, 0) = ListNo(i + 2) rngA.Offset(SbRow + 10, 0) = ListNo(i + 3) rngA.Offset(SbRow + 13, 0) = ListNo(i + 4) rngA.Offset(SbRow + 16, 0) = ListNo(i + 5) rngA.Offset(SbRow + 19, 0) = ListNo(i + 6) rngA.Offset(SbRow + 22, 0) = ListNo(i + 7) rngA.Offset(SbRow + 25, 0) = ListNo(i + 8) rngA.Offset(SbRow + 28, 0) = ListNo(i + 9) SbRow = SbRow + 30 '3行 * 10個分＃ Next End If For i = i To (i + (Spellcnt - 1) Mod 10) '端数or１０行以下の処理（Spellcnt=10のときi=0〜9となる） rngA.Offset(SbRow + 1, 0) = ListNo(i) SbRow = SbRow + 3 '3行置き＃ Next Sub01_End: Exit Sub Sub01_Err: MsgBox "マクロ実行エラー(SpellList)" & Chr(13) & Err.Description 'エラーメッセージ表示 End Sub '呪文listのソート（並び替え）は事前に自分でやっておくこと。（レベル順にするなら並び替え必須） 'レイアウトなど変更時は、コメント欄に＃がついてるあたりをチェックするといいかも。 'Spellcardシートは一番上の段の３枚を元に毎回書き直しているので、見栄えを良くするために変更している場合はがんばれ。 Sub ListToSpellCard() 'Cardmaker版 Ver3.5 On Error GoTo Sub02_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(strリストシート).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 Sub02_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 'SpellCard初期化（最初の２〜２６行を必要な回数コピー） Worksheets(strカードシート).Select 'spellcard_makerシートを選択 ' Range("A27", ActiveCell.SpecialCells(xlLastCell)).Select '２７行目以下全選択＃（呪文３つ以下でセーブ時A27〜BQ24となるため） Range("A27", "A65536").Select '２７行目以下全選択＃ Selection.EntireRow.Delete '行削除 If Spellcnt <= 0 Then GoTo Sub02_End '呪文数0件時、終了 End If Range("1:24").Copy 'コピー元（行数指定）を選択＃ If Spellcnt Mod 3 = 0 Then '３つ１セットとして何セット必要か？＃ Setcnt = Int(Spellcnt / 3) Else Setcnt = Int(Spellcnt / 3) + 1 End If EndLine = 24 + (Setcnt - 1) * 24 'コピー先の最終行を算出＃ If Setcnt > 1 Then '３つ以下の場合コピー不要 Range("25:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃ End If Application.CutCopyMode = False 'コピー元の選択表示を解除 Application.Goto Range("A1"), True 'カーソル位置初期化（不要っぽ） Application.ScreenUpdating = True '画面更新を復帰 'Spellbookの参照ｂﾉ値を転記 Set rngA = Range("M23") 'セットする最初のセルを指定＃ 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, 15) = ListNo(i + 1) '中央 rngA.Offset(SbRow, 30) = ListNo(i + 2) '右 SbRow = SbRow + 24 '3個/25行 ＃ Next End If '端数or２つ以下の処理 Select Case (Spellcnt Mod 3) Case 1 rngA.Offset(SbRow, 0) = ListNo(i) '左 rngA.Offset(SbRow, 5) = "" '中央 rngA.Offset(SbRow, 30) = "" '右 Case 2 rngA.Offset(SbRow, 0) = ListNo(i) '左 rngA.Offset(SbRow, 15) = ListNo(i + 1) '中央 rngA.Offset(SbRow, 30) = "" '右 End Select Sub02_End: '改ページを所定のカード行毎にくっつけたり、罫線を引っ張ったりする処理（追加） Dim CardLine As Integer CardLine = 24 '１カードに使用する行数　＃ i = CardLine - 1 '呪文Noの入力されている場所を指定 ＃ Do While Len(Trim(Sheets(strカードシート).Cells(i, Asc("M") - 64).Value)) > 0 '呪文Noの入力されている場所が空白なら処理を止める。（最初はL24） ＃ If (i + 1) Mod (CardLine * 3) = 0 Then '３カード行毎に改行を挿入し、新しいページの上罫線を引く。 ＃ Sheets(strカードシート).HPageBreaks.Add Before:=Cells(i + 2, 1) '呪文Noの２行下に改行を入れる　＃ ' Sheets(strカードシート).Range("A" & i + 2 & ":AS" & i + 2).Borders(xlEdgeTop).LineStyle = xlContinuous '呪文Noの２行下の行の上辺に罫線を入れる（列Aから列AMまで）　＃ End If i = i + CardLine '次の呪文Noの入力されている場所を指定 Loop Exit Sub Sub02_Err: MsgBox "マクロ実行エラー(SpellCard)" & Chr(13) & Err.Description 'エラーメッセージ表示 End Sub