人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロの質問です。「商品管理」シートに商品番号、商品名、販売価格等を記録しています。この「商品管理」シートからバーコードラベルを作成したいと考えています。
バーコードラベルを作成したい商品名を複数選択し、「商品管理」シートの"ラベル"列で指定した枚数だけバーコードラベルを作成していくマクロを作りたいと考えています。※画像参照
ワードの差し込み印刷は複数選択と指定枚数出すというバーコードラベルの性質上とワードを都度立ち上げなければならない煩わしさから用いません。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

1214933868
●拡大する

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:エクセル コメント コード データ バーコード
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●0ポイント

まず、サンプルデータを作るために作ったコードを紹介します。

Option Explicit

Private Const MaxGyou As Integer = 11  '行数

Sub MakeSheet()
 Dim i As Integer
 With Worksheets("バーコードラベル")
 .Range("A1:D7").Copy
 .Range("E1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("I1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("M1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("A1:D7").Copy Range("E1")
 .Range("A1:D7").Copy Range("I1")
 .Range("A1:D7").Copy Range("M1")
 
 For i = 1 To MaxGyou - 1
 .Rows("1:7").Copy Rows(i * 7 + 1)
 Next i
 End With
End Sub

このコードはバーコードラベルのA1:D7の範囲を横に4縦に11コピーするマクロです。

バーコードを1つ作って実行することで全てのバーコードに書式設定できます。

ここで一つがA4サイズになるように大きさを調整したり印刷の倍率を変更すればいいです。

また、Z方向順に印刷するためには、

メニューのファイル→ページの設定→シート→ページの方向で上から下を選択してください。


次に、

Sub MakeBarcode()
 Dim wsBar As Worksheet
 Dim wsKan As Worksheet
 Dim SNameRetu As Integer  '商品名列
 Dim SNumRetu As Integer  '商品番号列
 Dim BarRetu As Integer  'バーコード列
 Dim KakakuRetu As Integer  '価格列
 Dim LabelRetu As Integer  'ラベル列
 Dim kaisiRow As Integer  'バーコードラベル作成開始行
 Dim kaisiColumn As Integer  'バーコードラベル作成開始列
 
  '作業用変数
 Dim r As Range
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 Dim str As String
 Dim h As Variant
 
 If ThisWorkbook.Name <> "商品管理.xls" Or ActiveSheet.Name <> "商品管理" Then
 MsgBox "操作が誤っています。バーコードラベルを作成する場合は商品管理ファイルの" & _
 "商品管理シートの商品名列でマクロを実行してください。"
 Exit Sub
 End If
 
 Set wsBar = Worksheets("バーコードラベル")
 Set wsKan = Worksheets("商品管理")
 
  'タイトル列がない場合の処理
 Set r = wsKan.Rows(1).Find(what:="商品名", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品名の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNameRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品番号の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNumRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="バーコード", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "バーコードの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 BarRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="販売価格", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "販売価格の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 KakakuRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="ラベル", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "ラベルの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 LabelRetu = r.Column
 End If
 
  '商品名のセル選択しているか
 If Selection.Columns.Count <> 1 Or Selection.Column <> SNameRetu Then
 MsgBox ("商品名を選択してください。")
 Exit Sub
 End If
 
  'バーコードラベルが残っているか
 f = False
 For i = MaxGyou To 1 Step -1
 If wsBar.Cells(i * 7 - 2, 1).Value <> "" Or wsBar.Cells(i * 7 - 2, 5).Value <> "" Or _
 wsBar.Cells(i * 7 - 2, 9).Value <> "" Or wsBar.Cells(i * 7 - 2, 13).Value <> "" Then
 f = True
 Exit For
 End If
 Next i
 
 kaisiRow = 1
 kaisiColumn = 0
 If f Then
 If MsgBox("シートにバーコードラベルのデータが残っています。データを削除しますか?" & _
 vbNewLine & "[はい]→新たにラベルを作成。" & vbNewLine & _
 "[いいえ]→データの続きにラベルを作成。", vbYesNo) = vbYes Then
 For i = 1 To MaxGyou
 For j = 0 To 3
 wsBar.Cells(i * 7 - 6, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 5, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 4, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 2, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 1, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 4, j * 4 + 3).Value = ""
 wsBar.Cells(i * 7 - 2, j * 4 + 3).Value = ""
 Next j
 Next i
 Else
 kaisiRow = i + 1
 If kaisiRow > MaxGyou Then
 MsgBox "コードラベルを作成するスペースがありません"
 Exit Sub
 End If
 End If
 End If
 
 
  '転記作業
 For Each r In Selection
 If r.Row <> 1 Then
 For i = 1 To wsKan.Cells(r.Row, LabelRetu).Value
 str = StrConv(wsKan.Cells(r.Row, SNameRetu).Value, vbNarrow)
 wsBar.Cells(kaisiRow * 7 - 1, kaisiColumn * 4 + 1).Value = str
 h = Split(str, "/")
 If UBound(h) = 2 Then
 For j = 0 To 2
 wsBar.Cells(kaisiRow * 7 - 6 + j, kaisiColumn * 4 + 2).Value = h(j)
 Next j
 End If
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 1).Value = wsKan.Cells(r.Row, BarRetu).Value
 wsBar.Cells(kaisiRow * 7 - 6, kaisiColumn * 4 + 1).Value = "STYLE"
 wsBar.Cells(kaisiRow * 7 - 5, kaisiColumn * 4 + 1).Value = "COLOR"
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 1).Value = "STYLE"
 If kaisiColumn = 3 Then
 kaisiColumn = 0
 kaisiRow = kaisiRow + 1
 If kaisiRow > MaxGyou Then Exit Sub
 Else
 kaisiColumn = kaisiColumn + 1
 End If
 Next i
 End If
 Next r
 
End Sub

先のコードの

Private Const MaxGyou As Integer = 11 '行数

は後のバーコード作成コードでも使いますので一番上に書いておいてください。

この数字を変更することで11行以上にすることができます。


2 ● SALINGER
●0ポイント

Excelではシートでできることはシートでというのがあるので、マクロ実行時に数式や書式を変更することはしていません。

というのはフォントを変えたのに、マクロを実行したらなぜか戻ったということが起きるからです。

前の回答で説明不足でしたが、

A4セル(バーコードの書式設定がしてあるセル)の数式を

=IF(A5="","","*" & A5 & "*")

のようにして、MakeSheet()を実行して全てのバーコードラベルに数式を入れてみてください。


以下、修正したコードです。

Sub MakeBarcode()
 Dim wsBar As Worksheet
 Dim wsKan As Worksheet
 Dim SNameRetu As Integer  '商品名列
 Dim SNumRetu As Integer  '商品番号列
 Dim BarRetu As Integer  'バーコード列
 Dim KakakuRetu As Integer  '価格列
 Dim LabelRetu As Integer  'ラベル列
 Dim kaisiRow As Integer  'バーコードラベル作成開始行
 Dim kaisiColumn As Integer  'バーコードラベル作成開始列
 
  '作業用変数
 Dim r As Range
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 Dim str As String
 Dim h As Variant
 
 If ThisWorkbook.Name <> "商品管理.xls" Or ActiveSheet.Name <> "商品管理" Then
 MsgBox "操作が誤っています。バーコードラベルを作成する場合は商品管理ファイルの" & _
 "商品管理シートの商品名列でマクロを実行してください。"
 Exit Sub
 End If
 
 Set wsBar = Worksheets("バーコードラベル")
 Set wsKan = Worksheets("商品管理")
 
  'タイトル列がない場合の処理
 Set r = wsKan.Rows(1).Find(what:="商品名", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品名の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNameRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品番号の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNumRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="バーコード", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "バーコードの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 BarRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="販売価格", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "販売価格の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 KakakuRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="ラベル", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "ラベルの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 LabelRetu = r.Column
 End If
 
  '商品名のセル選択しているか
 If Selection.Columns.Count <> 1 Or Selection.Column <> SNameRetu Then
 MsgBox ("商品名を選択してください。")
 Exit Sub
 End If
 
  'バーコードラベルが残っているか
 f = False
 For i = MaxGyou To 1 Step -1
 If wsBar.Cells(i * 7 - 2, 1).Value <> "" Or wsBar.Cells(i * 7 - 2, 5).Value <> "" Or _
 wsBar.Cells(i * 7 - 2, 9).Value <> "" Or wsBar.Cells(i * 7 - 2, 13).Value <> "" Then
 f = True
 Exit For
 End If
 Next i
 
 kaisiRow = 1
 kaisiColumn = 0
 If f Then
 If MsgBox("シートにバーコードラベルのデータが残っています。データを削除しますか?" & _
 vbNewLine & "[はい]→新たにラベルを作成。" & vbNewLine & _
 "[いいえ]→データの続きにラベルを作成。", vbYesNo) = vbYes Then
 For i = 1 To MaxGyou
 For j = 0 To 3
 wsBar.Cells(i * 7 - 6, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 5, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 4, j * 4 + 2).Value = ""
 wsBar.Cells(i * 7 - 2, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 1, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 4, j * 4 + 3).Value = ""
 wsBar.Cells(i * 7 - 2, j * 4 + 3).Value = ""
 wsBar.Cells(i * 7 - 6, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 5, j * 4 + 1).Value = ""
 wsBar.Cells(i * 7 - 4, j * 4 + 1).Value = ""
 Next j
 Next i
 Else
 kaisiRow = i + 1
 If kaisiRow > MaxGyou Then
 MsgBox "コードラベルを作成するスペースがありません"
 Exit Sub
 End If
 End If
 End If
 
 
  '転記作業
 For Each r In Selection
 If r.Row <> 1 Then
 For i = 1 To wsKan.Cells(r.Row, LabelRetu).Value
 str = StrConv(wsKan.Cells(r.Row, SNameRetu).Value, vbNarrow)
 wsBar.Cells(kaisiRow * 7 - 1, kaisiColumn * 4 + 1).Value = str
 h = Split(str, "/")
 If UBound(h) = 2 Then
 For j = 0 To 2
 wsBar.Cells(kaisiRow * 7 - 6 + j, kaisiColumn * 4 + 2).Value = h(j)
 Next j
 End If
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 1).Value = wsKan.Cells(r.Row, SNumRetu).Value
 wsBar.Cells(kaisiRow * 7 - 6, kaisiColumn * 4 + 1).Value = "STYLE"
 wsBar.Cells(kaisiRow * 7 - 5, kaisiColumn * 4 + 1).Value = "COLOR"
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 1).Value = "SIZE"
 If kaisiColumn = 3 Then
 kaisiColumn = 0
 kaisiRow = kaisiRow + 1
 If kaisiRow > MaxGyou Then Exit Sub
 Else
 kaisiColumn = kaisiColumn + 1
 End If
 Next i
 End If
 Next r
 
End Sub

3 ● SALINGER
●1500ポイント ベストアンサー

前の回答では1000個とかになると、その都度書式のコピーをするのはオーバヘッドなので

書式のコピーで空のラベルを作るのと、バーコードのデータを書き込むのを別にしたのです。


マクロ実行時に書式をコピーするならば、以下のMakeBarcode()からMakeSheet()を呼び出してコピーするコードで。

データが無いときとデータの削除を選んだときにラベルの1つ目以外を削除して新たにラベルを43個作ってコピーするようにしました。

これは前のデータを残す場合、書式のコピーをするとおかしなことになるからです。

商品番号がA5セルに正しく表示されないというのは私の環境では表示されるので今のところ原因不明です。


Option Explicit

Private Const MaxGyou As Integer = 11  '行数

Sub MakeBarcode()
 Dim wsBar As Worksheet
 Dim wsKan As Worksheet
 Dim SNameRetu As Integer  '商品名列
 Dim SNumRetu As Integer  '商品番号列
 Dim BarRetu As Integer  'バーコード列
 Dim KakakuRetu As Integer  '価格列
 Dim LabelRetu As Integer  'ラベル列
 Dim kaisiRow As Integer  'バーコードラベル作成開始行
 Dim kaisiColumn As Integer  'バーコードラベル作成開始列
 
  '作業用変数
 Dim r As Range
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 Dim str As String
 Dim h As Variant
 
 Application.ScreenUpdating = False
 
 If ThisWorkbook.Name <> "商品管理.xls" Or ActiveSheet.Name <> "商品管理" Then
 MsgBox "操作が誤っています。バーコードラベルを作成する場合は商品管理ファイルの" & _
 "商品管理シートの商品名列でマクロを実行してください。"
 Exit Sub
 End If
 
 Set wsBar = Worksheets("バーコードラベル")
 Set wsKan = Worksheets("商品管理")
 
  'タイトル列がない場合の処理
 Set r = wsKan.Rows(1).Find(what:="商品名", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品名の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNameRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品番号の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNumRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="バーコード", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "バーコードの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 BarRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="販売価格", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "販売価格の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 KakakuRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="ラベル", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "ラベルの列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 LabelRetu = r.Column
 End If
 
  '商品名のセル選択しているか
 If Selection.Columns.Count <> 1 Or Selection.Column <> SNameRetu Then
 MsgBox ("商品名を選択してください。")
 Exit Sub
 End If
 
  'バーコードラベルが残っているか
 f = False
 For i = MaxGyou To 1 Step -1
 If wsBar.Cells(i * 7 - 2, 1).Value <> "" Or wsBar.Cells(i * 7 - 2, 5).Value <> "" Or _
 wsBar.Cells(i * 7 - 2, 9).Value <> "" Or wsBar.Cells(i * 7 - 2, 13).Value <> "" Then
 f = True
 Exit For
 End If
 Next i
 
 kaisiRow = 1
 kaisiColumn = 0
 If f Then
 If MsgBox("シートにバーコードラベルのデータが残っています。データを削除しますか?" & _
 vbNewLine & "[はい]→新たにラベルを作成。" & vbNewLine & _
 "[いいえ]→データの続きにラベルを作成。", vbYesNo) = vbYes Then
 Call MakeSheet
 Else
 kaisiRow = i + 1
 If kaisiRow > MaxGyou Then
 MsgBox "コードラベルを作成するスペースがありません"
 Exit Sub
 End If
 End If
 Else
 Call MakeSheet
 End If
 
 
  '転記作業
 For Each r In Selection
 If r.Row <> 1 Then
 For i = 1 To wsKan.Cells(r.Row, LabelRetu).Value
 str = StrConv(wsKan.Cells(r.Row, SNameRetu).Value, vbNarrow)
 wsBar.Cells(kaisiRow * 7 - 1, kaisiColumn * 4 + 1).Value = str
 h = Split(str, "/")
 If UBound(h) = 2 Then
 For j = 0 To 2
 wsBar.Cells(kaisiRow * 7 - 6 + j, kaisiColumn * 4 + 2).Value = h(j)
 Next j
 End If
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 3).Value = wsKan.Cells(r.Row, KakakuRetu).Value
 wsBar.Cells(kaisiRow * 7 - 2, kaisiColumn * 4 + 1).Value = wsKan.Cells(r.Row, SNumRetu).Value
 wsBar.Cells(kaisiRow * 7 - 3, kaisiColumn * 4 + 2).Value = wsKan.Cells(r.Row, BarRetu).Value
 wsBar.Cells(kaisiRow * 7 - 6, kaisiColumn * 4 + 1).Value = "STYLE"
 wsBar.Cells(kaisiRow * 7 - 5, kaisiColumn * 4 + 1).Value = "COLOR"
 wsBar.Cells(kaisiRow * 7 - 4, kaisiColumn * 4 + 1).Value = "SIZE"
 If kaisiColumn = 3 Then
 kaisiColumn = 0
 kaisiRow = kaisiRow + 1
 If kaisiRow > MaxGyou Then Exit Sub
 Else
 kaisiColumn = kaisiColumn + 1
 End If
 Next i
 End If
 Next r
 
 Application.ScreenUpdating = True
End Sub

Sub MakeSheet()
 Dim i As Integer
 With Worksheets("バーコードラベル")
 .Rows("8:65536").Delete
 .Columns("E:IV").Delete
 .Range("A1:D7").Copy
 .Range("E1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("I1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("M1").PasteSpecial Paste:=xlPasteColumnWidths
 .Range("E1").PasteSpecial Paste:=xlPasteFormats
 .Range("I1").PasteSpecial Paste:=xlPasteFormats
 .Range("M1").PasteSpecial Paste:=xlPasteFormats
 
 .Rows("1:7").Copy
 For i = 1 To MaxGyou - 1
 .Rows(i * 7 + 1 & ":" & i * 7 + 7).PasteSpecial Paste:=xlPasteFormats
 Next i
 Application.CutCopyMode = False
 End With
End Sub
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ