VBAで不特定枚数印刷をしたいです。

VBAで以下のような操作を行いたいのですが、
あまりVBAに詳しくなく分からず質問致しました。
分かりづらい内容で申し訳ございませんが、
どうぞよろしくお願いいたします。
画像に載っているエクセルで作成した１２個のカードのようなものに、
500件ほどあるエクセルデータから都度印刷したいデータを選び、
カードへ転記をして印刷をしたいです。
転記の順番は矢印通りです。

毎回、印刷したいデータ数は違うので、
このカード１２個が記載されているシートを何枚印刷するかは
分からない状態です。
シート１枚の印刷で済むときもあれば、シート数枚にわたって印刷する時もあります。

このような場合のマクロコードを教えて頂けますようよろしくお願いいたします

質問者からの補足コメント

• L = 3: K = 4
  
  For i = 2 To wsDate.Cells(Rows.Count, 1).End(xlUp).Row
  If wsDate.Cells(i, 2) <> "" Then
  For j = 0 To 4
  wsPrint.Cells(L + j, K).Value = wsDate.Cells(i, j + 3).Value
  Next j
  
  If L = 48 And K = 4 Then
  K = 11
  L = -6
  End If
  
  L = L + 9
  
  If L = 57 And K = 11 Then
  wsPrint.Range("D3:D53,K3:K53").ClearContents
  L = 3: K = 4
  End If
  End If
  Next i
  文字数オーバーで上のほうをカットしました＞＜

    補足日時：2022/08/02 19:35

• 一番左上のカード
  「使用工程」セルのアドレス : D3
  「メーカー」セルのアドレス : D4
  「背番号」セルのアドレス : D5
  「品番」セルのアドレス : D6
  「収容数」セルのアドレス: D7
  
  ひとつ下の２番めのカード
  「使用工程」セルのアドレス : D12
  ひとつ右の７番めのカードで
  「使用工程」セルのアドレス : K3

    補足日時：2022/08/02 21:23

No.4 ベストアンサー 回答者： KenKen_SP 回答日時： 2022/08/02 22:49

続き

'/CommandButton1クリックイベント
'
Private Sub CommandButton1_Click()

　　'シート定義
　　Dim src_sheet As Worksheet
　　Set src_sheet = ThisWorkbook.Worksheets(SRC_SHEETNAME)
　　Dim pnt_sheet As Worksheet
　　Set pnt_sheet = ThisWorkbook.Worksheets(PNT_SHEETNAME)

　　'データの走査範囲（2行目からA列の最終行まで）
　　Dim min_rownum As Long: min_rownum = 2
　　Dim max_rownum As Long: max_rownum = src_sheet.Cells(src_sheet.Rows.Count, "A").End(xlUp).Row
　　
　　'カード番号 card_index 1～12 左列,右列 それぞれ6カード
　　Dim card_index As Long: card_index = 1
　　
　　'転記開始
　　Dim i　　　　　　　As Long
　　Dim flag_printount As Boolean
　　'
　　For i = min_rownum To max_rownum
　　　　If src_sheet.Cells(i, "B").Value = "●" Then
　　　　　　'変数 card_index の値で基準セルの位置を変える
　　　　　　'基準セルとは各カードの「使用工程」を書き込むセル
　　　　　　'計算でもできるけど、わかりやすさ重視
　　　　　　Dim base_cell As Range
　　　　　　Select Case card_index
　　　　　　Case 1:　Set base_cell = pnt_sheet.Cells(3, "D")
　　　　　　Case 2:　Set base_cell = pnt_sheet.Cells(12, "D")
　　　　　　Case 3:　Set base_cell = pnt_sheet.Cells(21, "D")
　　　　　　Case 4:　Set base_cell = pnt_sheet.Cells(30, "D")
　　　　　　Case 5:　Set base_cell = pnt_sheet.Cells(39, "D")
　　　　　　Case 6:　Set base_cell = pnt_sheet.Cells(48, "D")
　　　　　　Case 7:　Set base_cell = pnt_sheet.Cells(3, "K")
　　　　　　Case 8:　Set base_cell = pnt_sheet.Cells(12, "K")
　　　　　　Case 9:　Set base_cell = pnt_sheet.Cells(21, "K")
　　　　　　Case 10: Set base_cell = pnt_sheet.Cells(30, "K")
　　　　　　Case 11: Set base_cell = pnt_sheet.Cells(39, "K")
　　　　　　Case 12: Set base_cell = pnt_sheet.Cells(48, "K")
　　　　　　End Select
　　　　　　'基準セルから Offset したセルに各データを転記
　　　　　　'例）Offset(2, 1) は基準セルから見て2行下,1列右のセル
　　　　　　With base_cell
　　　　　　　　.Offset(0, 0).Value = src_sheet.Cells(i, "C").Value '使用工程
　　　　　　　　.Offset(1, 0).Value = src_sheet.Cells(i, "D").Value 'メーカー
　　　　　　　　.Offset(2, 0).Value = src_sheet.Cells(i, "E").Value '背番号
　　　　　　　　.Offset(3, 0).Value = src_sheet.Cells(i, "F").Value '品番
　　　　　　　　.Offset(4, 0).Value = src_sheet.Cells(i, "G").Value '収容数
　　　　　　End With
　　　　　　'写真挿入（ハイパーリンクからアドレスを取得してます）
　　　　　　Dim img_filename As String
　　　　　　If src_sheet.Cells(i, "H").Hyperlinks.Count > 0 Then
　　　　　　　　img_filename = src_sheet.Cells(i, "H").Hyperlinks(1).Address
　　　　　　　　Call InsertPicture(img_filename, base_cell.Offset(0, 2).MergeArea)
　　　　　　End If
　　　　　　'次に書き込むカード番号
　　　　　　card_index = card_index + 1
　　　　　　'1件でも転記があったら印刷フラグを立てておく
　　　　　　flag_printount = True
　　　　End If
　　　　'card_index が12を超えていたら印刷処理&シート初期化
　　　　If card_index > 12 Then
　　　　　　'印刷したら印刷フラグは降ろす
　　　　　　pnt_sheet.PrintOut Preview:=True
　　　　　　flag_printount = False
　　　　　　'次に備えてシート初期化
　　　　　　Call DataClear
　　　　　　'初期化したら次の転記先カードは1番目に戻る
　　　　　　card_index = 1
　　　　End If
　　Next
　　'印刷フラグが立ったままなら最後のページを印刷
　　If flag_printount Then
　　　　pnt_sheet.PrintOut Preview:=True
　　　　Call DataClear
　　End If

End Sub

'/ 印刷シートの初期化
'
Private Sub DataClear()

　　'シート定義
　　Dim pnt_sheet As Worksheet
　　Set pnt_sheet = ThisWorkbook.Worksheets(PNT_SHEETNAME)
　　'値の消去
　　pnt_sheet.Range("D3:D53,K3:K53").ClearContents
　　'写真の消去(VBAで写真挿入時に名前に %DEL_ という識別子を付けてます)
　　Dim shp As Shape
　　For Each shp In pnt_sheet.Shapes
　　　　If shp.Name Like DEL_SHAPES_PREFIX & "*" Then
　　　　　　shp.Delete
　　　　End If
　　Next

End Sub

'/ 写真の挿入 img_filename：画像のファイル名 pos_cell: 貼付け先セル
'
Private Sub InsertPicture( _
　　ByRef img_filename As String, _
　　ByRef pos_cell As Range)

　　'memo: セルの大きさにあわせてますので縦横比が狂ってます

　　'シート定義
　　Dim pnt_sheet As Worksheet
　　Set pnt_sheet = pos_cell.Parent
　　'写真の差込
　　Dim shp As Shape
　　Set shp = pnt_sheet.Shapes.AddPicture( _
　　　　　　　　　　　　　　　 Filename:=img_filename, _
　　　　　　　　　　　　　　　 LinkToFile:=msoTrue, _
　　　　　　　　　　　　　　　 SaveWithDocument:=msoFalse, _
　　　　　　　　　　　　　　　 Left:=pos_cell.Left, _
　　　　　　　　　　　　　　　 Top:=pos_cell.Top, _
　　　　　　　　　　　　　　　 Width:=pos_cell.Width, _
　　　　　　　　　　　　　　　 Height:=pos_cell.Height)
　　'後で削除しやすいように名前に識別子をつけます
　　shp.Name = DEL_SHAPES_PREFIX & shp.Name

End Sub

この回答へのお礼

ありがとうございます！！
頂いたコードが素晴らしすぎて衝撃でした＞＜
画像の添付の仕方まで教えて下さりありがとうございます！！！
このような素晴らしいコードをサラッと書けること、大変尊敬します！

お恥ずかしながら補足に載せたコードを書くのに
試行錯誤で何日も費やしたのですが、
.printpreviewをどこに書いても１枚しか印刷できず、
そして繰り返し転記もあのコードが限界で、
試行錯誤すればするほどこんがらがってしまい、
こちらでお聞きした次第です＞＜
（知り合いで聞ける方もおらず・・）

頂いたコードを試してからお返事を差し上げたいのですが、
とてもレベルの高いコードなので、読み込んで理解して、
試せる段階になるまで日にちがだいぶかかるかと思いましたので、
早くお礼をお伝えしたく試す前にお礼をすることをお許しください。
素晴らしいコードを教えて下さり、本当にありがとうございます！！！
意を決してこちらでお聞きして本当に良かったです＞＜
本やネットを駆使して勉強をしているのですが、
業務で活かせるような応用になると、
書くコードが合っているのか合っていないのかも
分からなくなりこんがらがり、強引なぐちゃぐちゃなコードが仕上がります
・・・。
今回、恥を忍んでコードを載せたことで、
コードを見て頂くことの大切さを学びました。
（とても恥ずかしいですが＞＜）

そして「頑張っていますね」とおっしゃって頂けたことに
とても涙が出る思いでした。

ご親切にたくさん教えて頂き、本当に本当にありがとうございました！！

お礼日時：2022/08/03 05:25

No.3 回答者： KenKen_SP 回答日時： 2022/08/02 22:42

>コードに自信がなく、途中までのコードを載せることをためらった

自信があったらこの場は意味がないですよ。私も自信はありませんけど、先輩から人に見てもらうことが上達への近道だと教わりました。全然構わないと思います。

最初はどこかの VBA 案件を丸投げなのかも？と思ってました。
失礼しました。お詫びします。

頑張っていらっしゃることが良くわかりました、ありがとうございます。
サンプル書いてみました。

■サンプルについて
１．全てシートモジュールです
２．シート名は[入力], [印刷テンプレート]です
３．[入力] シートに ActiveXコントロールのボタンを配置（添付図）
４．[入力] シートで B列と H列に Dクリックイベントを追加してます
　　※画像パス取得にハイパーリンクが都合が良かったので
５．細かいエラートラップはしてません
６．添付図ではテーブル化してますが、動作に関係はありません

↓■以下、[入力]シートモジュール

'/シート名定義
'
Private Const PNT_SHEETNAME　　 As String = "印刷テンプレート"
Private Const SRC_SHEETNAME　　 As String = "データ"
Private Const DEL_SHAPES_PREFIX As String = "%DEL_"

'/Dクリックイベント
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　
　　'/Guard 1行目のDクリックは無視
　　If Target.Row = 1 Then Exit Sub
　　
　　'行番号で分岐処理します
　　Select Case Target.Column
　　Case 2 'B列(2)-----------------------------------
　　　　Cancel = True
　　　　'トグル的に●を書いたり消したり
　　　　Target.Value = IIf(Target.Value = "●", "", "●")
　　Case 8 'H列(8)-----------------------------------
　　Cancel = True
　　　　'ダイアログを開いて画像ファイルへのリンク設定
　　　　Dim img_filename As String
　　　　With Application.FileDialog(msoFileDialogFilePicker)
　　　　　　.AllowMultiSelect = False
　　　　　　.Filters.Clear
　　　　　　.Filters.Add "画像ファイル", "*.jpg,*.png,*.bmp,*.tif,*.gif,*.jpeg"
　　　　　　.InitialView = msoFileDialogViewLargeIcons
　　　　　　.InitialFileName = ThisWorkbook.Path & "\"
　　　　　　If .Show = -1 Then
　　　　　　　　img_filename = .SelectedItems(1)
　　　　　　End If
　　　　End With
　　　　If Len(img_filename) Then
　　　　　　Me.Hyperlinks.Add Anchor:=Target, _
　　　　　　　　　　　　　　　Address:=img_filename, _
　　　　　　　　　　　　　　　TextToDisplay:=Dir$(img_filename)
　　　　End If
　　End Select

End Sub

'長いので続きます

No.2 回答者： KenKen_SP 回答日時： 2022/08/02 20:00

頑張ってますね。

補足ありがとうございます。ただの丸投げでなくて安心しました。

ただ、基準セルを決めて、そこから Offset でデータ書き込んだ方が、ソースはすっきりします。

画像が不鮮明でセル配置がよくわからないのです。。

（転記先となる）一番左上のカードで
「使用工程」セルのアドレス
「メーカー」セルのアドレス
「背番号」セルのアドレス
「品番」セルのアドレス
「収容数」セルのアドレス

および、ひとつ下の２番めのカードで
「使用工程」セルのアドレス
および、ひとつ右の７番めのカードで
「使用工程」セルのアドレス

を補足して下さい。

この回答へのお礼

コードに自信がなく、途中までのコードを載せることをためらった為、
お手数をお掛け致しました＞＜
質問しておきながら画像も見づらく大変申し訳ないです。

アドレスを補足に記載致しました。
どうぞよろしくお願いいたします。

お礼日時：2022/08/02 21:21

No.1 回答者： KenKen_SP 回答日時： 2022/08/02 16:55

こんにちは。

>あまりVBAに詳しくなく分からず

スキルアップ目的であるなら、まずは、１行の明細データから１枚のカードへ転記するコードを動かなくても良いから補足して下さい。どこまでできてるんでしょう？

解決が目的なら有料で依頼した方が速いですね。

この回答へのお礼

ありがとうございます。
コードを途中まで書いてみたのですが、
ぐちゃぐちゃですが、補足に載せました。
画像の添付は後回しにしました。
そして転記も繰り返しがうまくいきませんでした＞＜；

お礼日時：2022/08/02 19:11