'「データtoリスト」＆「リストtoカード」マクロ　　'ItemCardmaker版 Ver1.00 '　「データtoリスト」マクロはデータWorksheetをソート（並び替え）したり（価格順にする等）、オートフィルタを３行目につけたりして使います。 '　「リストtoカード」マクロはリストWorksheetを作ったあとに使います。 '　レイアウトなど変更時は、コメント欄に＃がついてるあたりをチェックするといいかも。 '　リストシートは2〜5行目、カードシートは1〜22行を元に毎回書き直しているので、見栄えを良くするため等で変更している場合はがんばれ。 Option Explicit Sub データtoリスト() On Error GoTo Sub01_Err Dim myArea As Object, r As Object, Itemcnt 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("データ").Activate 'データシートをアクティブにする Range("A3").CurrentRegion.SpecialCells(xlCellTypeVisible).Select '行数算出 For Each myArea In Selection.Areas '各領域ごとに行数を取得して加算する Itemcnt = Itemcnt + myArea.Rows.Count Next Itemcnt = Itemcnt - 1 '見出し行を除くため「1」減算 '警告メッセージ表示（警告件数は てきとー If Itemcnt > 500 Then '警告件数チェック If 1 <> MsgBox("データが多いため時間がかなりかかります。" & Chr(13) & "このまま続けますか？" & _ Chr(13) & "（続行後、途中で止めたくなったら「CTRL＋Break」）", 17, "警告") Then GoTo Sub01_End End If End If '選択中のリストｂ配列へ保存 ReDim ListNo(0 To Itemcnt) 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 > 3 Then ListNo(i) = Cells(yy, 1).Value i = i + 1 End If Next Next 'リストsheet初期化（最初の4行を必要な回数コピー） Worksheets("リスト").Select 'リストシートを選択 Range("A6", "A65536").Select '6行目以下全選択＃ Selection.EntireRow.Delete '行削除 If Itemcnt <= 0 Then GoTo Sub01_End 'Item数0件時、終了 End If Range("2:5").Copy 'コピー元（行数指定）を選択＃ EndLine = 5 + Itemcnt * 4 - 4 'コピー先の最終行を算出＃ If Itemcnt > 1 Then '一行のみの場合コピー不要 Range("6:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃ End If Application.CutCopyMode = False 'コピー元の選択表示を解除 Application.Goto Range("A1"), True 'カーソル位置初期化（不要っぽ） Application.ScreenUpdating = True '画面更新を復帰 'リストsheetの参照ｂﾉ値を転記 Set rngA = Range("A2") 'セットする最初のセルを指定＃ SbRow = 0 'rngAからの相対距離用ワーク i = 0 '１０行より多い場合 If Itemcnt > 10 Then For i = 0 To Itemcnt - 1 - 10 Step 10 '一度に１０行づつ処理 rngA.Offset(SbRow, 0).MergeArea.Value = ListNo(i) rngA.Offset(SbRow + 4, 0).MergeArea.Value = ListNo(i + 1) rngA.Offset(SbRow + 8, 0).MergeArea.Value = ListNo(i + 2) rngA.Offset(SbRow + 12, 0).MergeArea.Value = ListNo(i + 3) rngA.Offset(SbRow + 16, 0).MergeArea.Value = ListNo(i + 4) rngA.Offset(SbRow + 20, 0).MergeArea.Value = ListNo(i + 5) rngA.Offset(SbRow + 24, 0).MergeArea.Value = ListNo(i + 6) rngA.Offset(SbRow + 28, 0).MergeArea.Value = ListNo(i + 7) rngA.Offset(SbRow + 32, 0).MergeArea.Value = ListNo(i + 8) rngA.Offset(SbRow + 36, 0).MergeArea.Value = ListNo(i + 9) SbRow = SbRow + 40 '4行 * 10個分＃ Next End If For i = i To (i + (Itemcnt - 1) Mod 10) '端数or１０行以下の処理（Itemcnt=10のときi=0〜9となる） rngA.Offset(SbRow, 0).MergeArea.Value = ListNo(i) SbRow = SbRow + 4 '4行置き＃ Next Sub01_End: Application.ScreenUpdating = True '画面の更新を復帰 Exit Sub Sub01_Err: MsgBox "マクロ実行エラー" & Chr(13) & Err.Description 'エラーメッセージ表示 End Sub ' Sub リストtoカード() On Error GoTo Sub02_Err Dim myArea As Object, r As Object, Itemcnt As Integer, Setcnt As Integer, SbRow As Long Dim yy As Long, i As Integer, EndLine As Integer Dim rngA As Range Dim ListNo() As Integer '番号記憶用配列宣言 Application.ScreenUpdating = False '画面の更新を行わない '表示行を全て選択 Worksheets("リスト").Activate 'リストシートをアクティブにする Range("A3").CurrentRegion.SpecialCells(xlCellTypeVisible).Select 'データ数算出 For Each myArea In Selection.Areas '各領域ごとに行数を取得して加算する Itemcnt = Itemcnt + myArea.Rows.Count Next Itemcnt = (Itemcnt - 1) / 4 '見出し行を除くため「1」減算 '警告メッセージ表示（警告件数は てきとー If Itemcnt > 100 Then '警告件数チェック If 1 <> MsgBox("データが多いため時間がかなりかかります。" & Chr(13) & "このまま続けますか？" & _ Chr(13) & "（続行後、途中で止めたくなったら「CTRL＋Break」）", 17, "警告") Then GoTo Sub02_End End If End If '表示中のリストｂ配列へ保存 ReDim ListNo(0 To Itemcnt) yy = 2 For i = 0 To (Itemcnt -1) ListNo(i) = Cells(yy, 1).Value yy = yy + 4 Next 'カードsheet初期化（最初の4行を必要な回数コピー） Worksheets("カード").Select 'カードシートを選択 Range("A23", "A65536").Select '23行目以下全選択＃ Selection.EntireRow.Delete '行削除 If Itemcnt <= 0 Then GoTo Sub02_End 'Item数0件時、終了 End If Range("1:22").Copy 'コピー元（行数指定）を選択＃ If Itemcnt Mod 2 = 0 Then '２つ１セットとして何セット必要か？＃ Setcnt = Int(Itemcnt / 2) Else Setcnt = Int(Itemcnt / 2) + 1 End If EndLine = Setcnt * 22 'コピー先の最終行を算出＃ If Setcnt > 2 Then '２つ以下の場合コピー不要 Range("23:" & EndLine).PasteSpecial Paste:=xlPasteAll '次の行と最下行を指定して貼り付け＃ End If Application.CutCopyMode = False 'コピー元の選択表示を解除 Application.Goto Range("A1"), True 'カーソル位置初期化（不要っぽ） Application.ScreenUpdating = True '画面更新を復帰 'リストsheetの参照ｂﾉ値を転記 Set rngA = Range("F21") 'セットする最初のセルを指定＃ SbRow = 0 'rngAからの相対距離用ワーク i = 0 '２以上の場合 If Itemcnt >= 2 Then For i = 0 To (Itemcnt - (Itemcnt Mod 2) - 2) Step 2 '一度に１行(２つ)づつ処理 rngA.Offset(SbRow, 0) = ListNo(i) '左 rngA.Offset(SbRow, 7) = ListNo(i + 1) '右 SbRow = SbRow + 22 '2個/22行 ＃ Next End If '端数or１つの処理 Select Case (Itemcnt Mod 2) Case 1 rngA.Offset(SbRow, 0).Value = ListNo(i) '左 rngA.Offset(SbRow, 7).Value = "" '右 End Select Sub02_End: Exit Sub Sub02_Err: MsgBox "マクロ実行エラー" & Chr(13) & Err.Description 'エラーメッセージ表示 End Sub