QRコード作成マクロについて

お世話になっております。

QRコードを使ってラベルを作ろうと思います。
QRコード単体を作成はできましたが、どのように連続で処理させればよいか悩んでいます。

やりたいこととしては、
A8セルの情報をQRコード化してD2に貼り付け
A15セルの情報をQRコード化してD9に貼り付け
A22セルの情報をQRコード化してD16に貼り付け
A29セルの情報をQRコード化してD23に貼り付け
A36セルの情報をQRコード化してD30に貼り付け
これを列を移動させて連続して処理させたいです。

下記に現状のコードを記載します。
Sub createQRCode()

Dim ws As Worksheet
Dim xObjOLE As OLEObject

Dim topPosition As Double
Dim leftPosition As Double

Set ws = Worksheets("Sheet1")

Set xObjOLE = ws.OLEObjects.Add("BARCODE.BarCodeCtrl.1")

With xObjOLE.Object
'QRコード(=11)を指定
.Style = 11
.Value = Cells(8, 1).Value
End With

With ws.Range("D2").MergeArea
topPosition = .Top
leftPosition = .Left
End With

With xObjOLE
.Height = 19.5
.Width = 49.5
.Top = topPosition
.Left = leftPosition
End With

Set xObjOLE = Nothing

End Sub


マクロに関して初心者で無知の為
お力添え頂ければ幸いです。
よろしくお願いいたします。

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

• 印刷用紙の関係上、範囲はこれ以上増えません。

    補足日時：2022/11/26 18:02

No.3 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/11/27 10:42

元のcreateQRCodeに多少手を加えました。

以下のようにしてください。（QR5X5を呼び出してください）

Sub QR5X5()
Dim wy As Long '下方向へのブロック番号
Dim wx As Long '右方向へのブロック番号
For wy = 1 To 5
For wx = 1 To 5
Call createQRCode(wy, wx)
Next
Next
End Sub
Sub createQRCode(wy As Long, wx As Long)
Dim wrow1 As Long '入力値行
Dim wcol1 As Long '入力値列
Dim wrow2 As Long 'QRコード貼り付行
Dim wcol2 As Long 'QRコード貼り付列
wrow1 = 7 * (wy - 1) + 8
wcol1 = 5 * (wx - 1) + 1
wrow2 = 7 * (wy - 1) + 2
wcol2 = 5 * (wx - 1) + 4
Dim ws As Worksheet
Dim xObjOLE As OLEObject

Dim topPosition As Double
Dim leftPosition As Double

Set ws = Worksheets("Sheet1")

Set xObjOLE = ws.OLEObjects.Add("BARCODE.BarCodeCtrl.1")

With xObjOLE.Object
'QRコード(=11)を指定
.Style = 11
.Value = Cells(wrow1, wcol1).Value
End With

With ws.Cells(wrow2, wcol2).MergeArea
topPosition = .Top
leftPosition = .Left
End With

With xObjOLE
.Height = 19.5
.Width = 49.5
.Top = topPosition
.Left = leftPosition
End With

Set xObjOLE = Nothing

End Sub

この回答へのお礼

返信ありがとうございます。
私のコードを元に改良していただいたおかげで、内容がわかりやすく助かりました。
今後改修するかもしれないので、自分でできるように勉強してみます。

お礼日時：2022/11/27 11:40

No.2 回答者： fujillin 回答日時： 2022/11/26 17:41

こんにちは

ご質問の文章に限ってよいのなら・・

単純に列挙してしまって、
For Each c in Range("A8,A15,A22,A29,A36")
　’対象の値を c.Value
　'貼り付け先を c.Offset(-6,3) にして処理
Next c
のようにしてループすれば終わると思いますけれど、添付の図を見ると対象範囲がもっと広そうな・・


範囲不定なら、まず処理対象の範囲を取得してから、その中で行を7行おき、列は5列おきにループするような構成にしておけば良いのではないでしょうか？
For rw=8 To maxRow Step 7
　For col = 1 To maxCol Step 5
　　’ 1件分の処理
　　' 処理対象セルは Cells(rw, col) になる
　Next col
Next rw
みたいな感じです。

この回答へのお礼

返信ありがとうございます。
参考にさせて頂きます。
今後改修するかもしれないので、自分でできるように勉強してみます。

お礼日時：2022/11/27 11:37

No.1 回答者： めくりや 回答日時： 2022/11/26 17:24

もしかして始めてVBAで組む人ですか？もしかして繰り返し処理を知らないですか？そういう基本的なことはVBAで検索すればやまほど初心者学習サイトが見つかりますが。

この回答へのお礼

返信ありがとうございます。
すみません。VBA初心者です。勉強します。

お礼日時：2022/11/27 11:42