id:icta
ポイントあり1500ptベストアンサーあり
コンピュータ

1214933868 エクセルのマクロの質問です。「商品管理」シートに商品番号、商品名、販売価格等を記録しています。この「商品管理」シートからバーコードラベルを作成したいと考えています。

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

回答の条件
  • 1人10回まで
  • 登録：
  • 終了：2008/07/08 00:24:22
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:SALINGER No.3

回答回数3454ベストアンサー獲得回数969

ポイント1500pt

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

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


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

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

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

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


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

その他の回答（2件）

id:SALINGER No.1

回答回数3454ベストアンサー獲得回数969

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

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の範囲を横に４縦に１１コピーするマクロです。

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

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

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

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


次に、

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 '行数

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

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

id:SALINGER No.2

回答回数3454ベストアンサー獲得回数969

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

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

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

Ａ４セル（バーコードの書式設定がしてあるセル）の数式を

=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
id:SALINGER No.3

回答回数3454ベストアンサー獲得回数969ここでベストアンサー

ポイント1500pt

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

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


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

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

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

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


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

コメント（8件)

  • id:icta
    icta 2008/07/02 02:40:18
    このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    エクセルを知らなくてもで簡単にバーコードラベルを作成できるマクロを作成したいと考えています。
    お知恵とお力をお借りできれば幸いです。
    仕様で何かご不明な点ありましたらお知らせください。


    ■マクロの仕様

    ○概要
    ・「商品管理」シートでバーコードラベルを作成したい商品のラベル枚数を"ラベル"列に入力。
    ・「商品管理」シートでバーコードラベルを作成したい商品名を複数選択。
    ・マクロ実行。
    ・バーコードラベルシートにデータが残っている場合は、次のメッセージを出す。
    　「シートにバーコードラベルのデータが残っています。データを削除しますか？
    　[はい]→新たにラベルを作成。
    　[いいえ]→データの続きにラベルを作成」
    　[はい]を選択したら、前回のデータはすべて削除し、新たなラベルを最初から作成する。
    　[いいえ]を選択したら、前回のデータの続きからラベルを作成する。続きとは4片並ぶ行の下を意味する。もし左側に1片、右側に使用されない3片があってもその行のの左側から作成を始める。前回と今回のラベルを区別しやすくするため。
    ・「商品管理」シートで商品名を選択した行のラベル枚数を確認、ラベルを指定枚数分作成する。
    ・「バーコードラベル」シートに指定枚数作成したら次に選択した商品に移る
    ・選択したすべての商品を指定したラベル枚数分作成し終えたらマクロを終了する。

    ○詳細
    ・A4用紙44面(4面×11面)使用。
    ・A列は必ずしも商品番号列ではなく、B列も同様必ずしも商品名列ではない。列が入れ替わることがあるので列名で対応する列位置を確認する。但し、タイトル行は1行目にある。
    ・商品名は半角カナに変換する。それから区切記号"/"で分け、STYLE、COLOR、SIZEとする。
    　カーディガン/ピンク/ワンサイズ
    　　↓
    　ｶｰﾃﾞｨｶﾞﾝ/ﾋﾟﾝｸ/ﾜﾝｻｲｽﾞ　※半角カナ
    　　↓　
    　STYLE　ｶｰﾃﾞｨｶﾞﾝ
    　COLOR　ﾋﾟﾝｸ
    　SIZE　 ﾜﾝｻｲｽﾞ
    ・バーコードはフォントで書式設定してある。
    ・「バーコードラベル」シートには文字サイズ、フォントなど見栄えの要素はすべて書式設定してある。マクロで指定する必要はない。
    ・STYLE、COLOR、SIZEの文字列はマクロで入力する。
    ・バーコードラベル1片はマージンが1列1行設けてある。
    ・バーコードラベルは大文字Zの書き順と同じ向きと順序で作成する。
    ・マクロは「商品管理.xls」の「商品管理」シートの"商品名"列で実行する。もしこれ以外の場所でマクロが実行された場合は▼次のメッセージを出す。
    　「操作が誤っています。バーコードラベルを作成する場合は商品管理ファイルの商品管理シートの商品名列でマクロを実行してください。」


    ■サンプルデータ（半角スペース区切り）

    商品記号 商品名 バーコード 販売価格 入庫数 ラベル 分類 発売日 商品番号
    S060302PK1 カーディガン/ピンク/ワンサイズ *S060302PK1* 8000 19 20 トップス 11/21 1
    H020101SV3 リング/シルバー/9号 *H020101SV3* 18000 3 4 ジュエリー 11/21 1

    ※バーコードには▼次の計算式が入っている。
    ="*"&A2&"*"
    ="*"&A3&"*"
  • id:SALINGER
    SALINGER 2008/07/02 13:27:52
    仕様で質問があります。
    バーコードの作成されるシート名はバーコードラベルでしょうか。図ではバーコードラベルがデータのあるシートのようですが。
    ＞A4用紙44面(4面×11面)使用
    バーコード一つがＡ４サイズで横４縦１１ということでしょうか？
  • id:icta
    icta 2008/07/02 14:06:10
    ＞SALINGERさん
    いつもお世話になっています。

    ＞バーコードの作成されるシート名はバーコードラベルでしょうか。図ではバーコードラベルがデータのあるシートのようですが

    はい、バーコードの作成されるシート名は「バーコードラベル」シートです。

    ＞バーコード一つがＡ４サイズで横４縦１１ということでしょうか？

    はい、そのとおりです。

    もし何か他にご不明な点がありましたらお知らせください。
    それではよろしくお願いいたします。
  • id:icta
    icta 2008/07/03 02:28:49
    > SALINGERさん

    早々のご回答ありがとうございました。
    いつも迅速な対応に大変感謝しております。

    さて、いただいたマクロを実行して、次の点がうまく行かないことが判明しました。
    マクロを自力で修正しよう思ったのですが、うまく行かなくてあきらめざるを得ませんでした。
    まだ荷が重過ぎるようです。
    ご都合のつくときに修正方法をお知らせいただければ幸いです。
    それではよろしくお願いいたします

    ○”SIZE”がない。
    修正前
    STYLE
    COLOR
    STYLE
    ↓
    修正後
    STYLE
    COLOR
    SIZE

    ○STYLE、COLOR、STYLEが削除されない。
    データを削除しますか？というメッセージで”[はい]→新たにラベルを作成”を選ぶと商品名などは消えるがSTYLE、COLOR、STYLEの文字列が削除されずにシート状に残ったままになる。

    ○A1からD7の書式の内容がコピーされない。
    A1:D7の範囲の書式（列幅、行高さ、フォント、文字サイズ等）がA1:D7以外の場所へコピーされない。
    エクセルのバージョンはExcel2003。

    ○バーコードの位置を修正
    修正前
    A5　*S060302PK1*
    ↓
    修正後
    B4　*S060302PK1*

    ※*S060302PK1*はバーコードCODE39の形式。
    　バーコードを文字で表せないため、バーコードフォントを使う前のセル内容を記載。

    ○商品番号がバーコード用の数字になっている
    修正前
    A5　*S060302PK1*
    ↓
    修正後
    A5　S060302PK1
  • id:SALINGER
    SALINGER 2008/07/03 10:33:21
    ＞A1からD7の書式の内容がコピーされない。
    バーコードラベルには書式設定が既にしてあるということでしたので、MakeBarcode()では書式のコピーはしていません。
    MakeSheet()は、既に有る書式設定を変更するのを簡単にするための別のマクロです。

    ＞バーコードの位置を修正
    既に書式設定がしてあるということでA4セルにはA5セルを参照する数式が入ってるものと思ってました。

    ＞商品番号がバーコード用の数字になっている
    ＞”SIZE”がない。
    こちらのミスでした。

    ＞STYLE、COLOR、STYLEが削除されない。
    見出しはデータではないと思いましたので削除していませんでした。
  • id:icta
    icta 2008/07/03 12:40:30
    >SALINGERさん

    早々の修正ありがとうございました。
    早速試してみましたが何点かうまくいかないところがあります。

    私は説明が下手なので画像にしてまとめてみました。
    http://f.hatena.ne.jp/icta/20080703123325
    これなら多少判りやすくなったと思います。

    ご都合のつくときに修正方法をお知らせいただければ幸いです。
    それではよろしくお願いいたします
  • id:SALINGER
    SALINGER 2008/07/03 15:41:26
    図で１と表示されてるＡ５セルは右詰インデントが入ってるとかではない？
    もしくは下詰で縦字になってるとか。
  • id:icta
    icta 2008/07/04 06:48:52
    >SALINGERさん
    早々のご回答ありがとうございました。
    A5セルはよくよく見直したら私の単純ミスでした。
    希望通りの動作を確認できました。
    バーコードリーダーが届きましたら、全ての商品にこのバーコードを取り付ける予定です。
    恐らく問題ないと思いますが、いままでのように運用してみて変更点などに気がつくことがありますので、いったん質問を締切、運用後、問題が生じなければ質問を終了いたします。
    それまでもうしばらくお待ちいただけますでしょうか？
    運用後に変更点に気がつきましたら、またコメントを付けます。
    ご都合のよいときにお力をお借りできれば幸いです。
    質問終了は来週の水曜日を予定しております。
    このマクロがあれば、誰でもどこでもバーコードを簡単に出すことができ大変便利です。
    本当にありがとうございました。

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ