アンケート案件 x 乱数のバリアブル・プリント by ChatGPT & perplexity

2024年8月29日 00:20

最近自治体関係でやっているアンケート調査の案件が忙しく、また複数件重なって来ており大変な毎日です。
今回取り上げるのは表1にバリアブル印字のある仕事で、4桁の数字の乱数を生成し表1に入れて欲しいという顧客指示。短納期で余裕がなかったのでAIの手を借りて乱数生成マクロを自作した話です。

印刷仕様：
①A4仕上がり10p墨1/1平綴じ+巻三つ折り
※表1に乱数4桁数字
②送信用封筒長3（顧客支給）料金別納マーク+宛名をPODで印字
③返信用封筒長3クラフト70gテープスチック墨1/0 巻三つ折り
以上3000セット封入封緘して局出し
下版8/28AM
局出し9/4完了
作業日数5日営業日（5営業日目に局出しまで）

※10ｐ3000部はオフセット印刷し、後で表1をPODで追い刷りし、丁合して中綴じ機で平綴じします。印刷会社じゃない人は分からんよね^^;
※平綴じはペラ丁合なんで納期キツイです（泣）でも可変が乱数なので、ヤレ管理不要なのが不幸中の幸い。また弊社封入機があるので、封入の方が製本より早く、こんな時助かります。

10ｐ平綴じ冊子の表1赤枠内に4桁の数字で乱数（ダブりのない数字の組み合わせで使って良い数字は0001～9999まで）という指定。乱数だとヤレになったら捨てても構わないので楽です。webの回答と郵送の回答がダブって同じ人が出していないか？等のチェックのために入れるらしいです。

サンプル：こんな感じ。ちょっと大きめMeiryoUI 18pointにしました。もう少し小さい文字指定で桁が多かったりアルファベット入りだとOCRBを使ったりする事が多いです。見間違いを防ぐ意味でOCRBは最適です。

でメインの乱数生成ですが、エクセルファイル.xlsmにVBAで書きました。

必要事項C1~C3に入力して乱数生成ボタン押下でA列にダブりなく乱数が生成されます。当然マクロ内ではダブりチェックもやってます。でもよく見るとsheet1では左の0が抜けてる（数値なので）なので左0埋めして隣のシートに書き出すようにしました。sheet1にダイレクトに0埋め数字（要は文字列）として出すのは、何度も試行錯誤（Aiが）したけどうまくできなかったです。

vbaのコードです。

Sub GenerateRandomNumbers()
    Dim NumCells As Long
    Dim MinValue As Long
    Dim MaxValue As Long
    Dim i As Long
    Dim RndNumber As Long
    Dim Cell As Range
    Dim RandomNumbers As New Collection
    Dim MaxDigits As Long
    
    ' Sheets(1)のA列をクリア
    Sheets(1).Columns("A:A").ClearContents
    Sheets(2).Columns("A:A").ClearContents

    ' パラメータを設定
    NumCells = Range("C1").Value ' 生成する乱数の数
    MinValue = Range("C2").Value ' 乱数の最小値
    MaxValue = Range("C3").Value ' 最大桁数を求めるための最大値
    MaxDigits = Len(CStr(MaxValue)) ' 最大桁数

    ' 重複のない乱数を生成
    Do While RandomNumbers.Count < NumCells
        RndNumber = WorksheetFunction.RandBetween(MinValue, MaxValue)
        On Error Resume Next
        RandomNumbers.Add RndNumber, CStr(RndNumber)
        On Error GoTo 0
    Loop

    ' 生成した乱数をセルに出力
    i = 1
    For Each Cell In Sheets(1).Range("A1:A" & NumCells)
        Cell.Value = RandomNumbers.Item(i)
        i = i + 1
    Next Cell
    
    ' 乱数を最大桁数に合わせて左0埋めしてSheets(2)に出力
    i = 1
    For Each Cell In Sheets(1).Range("A1:A" & NumCells)
        ' Format関数で左0埋め
        Sheets(2).Cells(i, 1).NumberFormat = "@" ' セルをテキスト形式に設定
        Sheets(2).Cells(i, 1).Value = Format(Cell.Value, String(MaxDigits, "0"))
        i = i + 1
    Next Cell
End Sub

この記事が気に入ったらサポートをしてみませんか？