プロが教える店舗&オフィスのセキュリティ対策術

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

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

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

「VBAで不特定枚数印刷をしたいです。」の質問画像

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

  • 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

    ひとつ下の2番めのカード
    「使用工程」セルのアドレス : D12
    ひとつ右の7番めのカードで
    「使用工程」セルのアドレス : K3

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

A 回答 (4件)

続き



'/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
「VBAで不特定枚数印刷をしたいです。」の回答画像4
    • good
    • 0
この回答へのお礼

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

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

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

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

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

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

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


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

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

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

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

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

'/シート名定義
'
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

'長いので続きます
「VBAで不特定枚数印刷をしたいです。」の回答画像3
    • good
    • 0

頑張ってますね。


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

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

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

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

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

を補足して下さい。
    • good
    • 0
この回答へのお礼

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

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

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

こんにちは。



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

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

解決が目的なら有料で依頼した方が速いですね。
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

このカテゴリの人気Q&Aランキング