エクセルにバーコードを画像で一括挿入する

URLをコピーする
URLをコピーしました!

この記事を作るにあたり参考にさせていただいたサイトです
バーコードの作成

JANコード、EANコード以外のバーコードも作成できる記事を下記にアップしました
フリーソフトを使ってバーコードを作成する方法

エクセルのリストにバーコード(JANコード・EANコード)を画像で一括挿入する方法をご紹介します。
※エクセル以外のソフト(フリーウェア・シェアウェアに限らず)は使いません。エクセルだけ有れば大丈夫です(アクセスも必要ありません)
※エクセル初心者でも使えるよう説明するつもりです

下の画像のように一括でバーコード画像を挿入します。
元リスト

バーコード挿入済みリスト

①エクセルファイルの準備
今回紹介する方法は、JANコードやEANコードの入力されているセルを基準にして「何列隣り(となり)にバーコードを挿入する」という事を指定します
個別には指定できません。(行程を分ければ個別に出来ますが、エクセル初心者を対象に書いている記事ですので)
そのため、エクセルファイルの列構成はあらかじめ調整しておいてください(先頭から最後まで同じ列なら問題ありません)
また、縦に複数列有る場合でも、JANコードとバーコードを挿入する列の列数の関係が同じなら問題ありません
模範的なリスト1
模範的なリスト2

②VBAコードを標準モジュールに貼り付ける
「Alt」を押しながら「F11」を押してください
下のような画面が出てくると思います
赤枠で囲った部分のメニューが出ていない場合は「Ctrl」を押しながら「r」を押してください
VBEを立ち上げる

目的のファイル名の上で右クリック

「挿入」をクリック

「標準モジュール」をクリック
標準モジュールの挿入

すると右側に大きな白いスペースが現れたと思います
※↓画像の赤枠部分
標準モジュールの場所

このスペースに以下のコードをコピペしてください

Option Explicit
Function CHECKDIGIT(ByVal target As Range) As String
    Dim strJAN As Integer
    Dim i As Integer
    Select Case Len(target)
        Case 12, 13
            i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
                CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
            i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
                    CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
            strJAN = Right(10 - CInt(Right(i, 1)), 1)
            CHECKDIGIT = strJAN
        Case 7, 8
            i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
                + CInt(Mid(target, 7, 1))) * 3
            i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
            strJAN = Right(10 - CInt(Right(i, 1)), 1)
            CHECKDIGIT = strJAN
        Case Else
            Exit Function
    End Select
End Function
Sub MYBARCODECREATE()
    Application.ScreenUpdating = False
    Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
    Dim c As Range
    Dim mycode As String
    Dim myhdch As String
    Dim sh As Worksheet, shbar As Worksheet
    Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
    Dim h
    myheadchar13 = Array("aaaaaa", "aababb", "aabbab", "aabbba", "abaabb", "abbaab", "abbbaa", "ababab", "ababba", "abbaba")
    myleftodd13 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
    mylefteven13 = Array("2122111", "2112211", "2211211", "2122221", "2211121", "2111221", "2222121", "2212221", "2221221", "2212111")
    myrighteven13 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
    myleftodd8 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
    myrighteven8 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
    i = 1
    Set sh = ActiveSheet
    For Each c In Selection
        Select Case Len(c)
            Case 8, 13
                If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
                    c.Interior.Color = 16711680
                    MsgBox "CHECK DIGIT ERROR" & vbCrLf & c.Address(False, False)
                    i = i + 1
                End If
                If i > 1 Then
                    Exit Sub
                End If
        End Select
    Next
    If IMEStatus <> vbIMEModeOff Then
        SendKeys "{kanji}"
    End If
    x = InputBox("何列右にバーコードを作成しますか?")
    Worksheets.Add
    ActiveSheet.Name = "mysh"
    Set shbar = Worksheets("mysh")
    Cells.Interior.Color = 16777215
    Cells.ColumnWidth = 0.08
    Rows("2:2").RowHeight = 15
    Rows("3:3").RowHeight = 4.5
    Rows("4:4").RowHeight = 4.5
    Cells.Font.Size = 6
    Range("Q3").NumberFormatLocal = "000000"
    Range("BL3").NumberFormatLocal = "000000"
    With Range("A3:K4")
        .Merge
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    With Range("Q3:BD4")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    With Range("BL3:CY4")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    Range("M2:M3").Merge
    Range("O2:O3").Merge
    Range("BG2:BG3").Merge
    Range("BI2:BI3").Merge
    Range("DA2:DA3").Merge
    Range("DC2:DC3").Merge
    Rows("6:6").RowHeight = 15
    Rows("7:7").RowHeight = 4.5
    Rows("8:8").RowHeight = 4.5
    Range("M6:M7").Merge
    Range("O6:O7").Merge
    Range("AS6:AS7").Merge
    Range("AU6:AU7").Merge
    Range("BY6:BY7").Merge
    Range("CA6:CA7").Merge
    With Range("Q7:AP8")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    With Range("AX7:BW8")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    Range("Q7").NumberFormatLocal = "0000"
    Range("AX7").NumberFormatLocal = "0000"
    sh.Activate
    For Each c In Selection
        If Len(c) = 12 Or Len(c) = 13 Then
            mycode = "222222222222121"
                myhdch = myheadchar13(Left(c, 1))
            For s = 2 To 7
                Select Case Mid(myhdch, s - 1, 1)
                    Case "a"
                        mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
                    Case "b"
                        mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
                End Select
            Next s
            mycode = mycode & "21212"
            For t = 8 To 12
                mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
            Next t
            mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
            mycode = mycode & "121222222222222"
            shbar.Range("A3").Value = Left(c, 1)
            shbar.Range("Q3").Value = Mid(c, 2, 6)
            shbar.Range("BL3").Value = Mid(c, 8, 5) & CHECKDIGIT(c)
            For w = 1 To Len(mycode)
                If Mid(mycode, w, 1) = 1 Then
                    shbar.Cells(2, w).Interior.Color = 0
                End If
            Next w
            shbar.Range("A2:DO4").CopyPicture Appearance:=xlScreen, Format:=xlPicture
            c.Offset(, x).PasteSpecial
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = c.Height - 4
                .Width = c.Offset(0, x).Width - 4
                .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
                .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
            End With
            shbar.Cells.Interior.Color = 16777215
        End If
        If Len(c) = 7 Or Len(c) = 8 Then
            mycode = "222222222222121"
            For y = 1 To 4
                mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
            Next y
            mycode = mycode & "21212"
            For z = 5 To 7
                mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
            Next z
            mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
            mycode = mycode & "121222222222222"
            For p = 1 To Len(mycode)
                If Mid(mycode, p, 1) = 1 Then
                    shbar.Cells(6, p).Interior.Color = 0
                End If
            Next p
            shbar.Range("Q7") = Left(c, 4)
            shbar.Range("AX7") = Mid(c, 5, 3) & CHECKDIGIT(c)
            shbar.Range("A6:CM8").CopyPicture Appearance:=xlScreen, Format:=xlPicture
            c.Offset(, x).PasteSpecial
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = c.Height - 4
                .Width = c.Offset(0, x).Width - 4
                .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
                .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
            End With
            shbar.Cells.Interior.Color = 16777215
        End If
    Next c
    Application.DisplayAlerts = False
        Worksheets("mysh").Delete
    Application.DisplayAlerts = True
End Sub

③今貼り付けたプログラムを実行する
バーコードを作りたいJANコード・EANコードを選択してください
1列の場合はそのままマウスをドラッグして範囲選択
範囲を選択

複数の離れた範囲の場合は 「Ctrl」 を押しながら選択範囲を設定してください
範囲を選択

「開発タブ」の「マクロ」を選択
開発タブが表示されて無い場合は開発タブを表示する方法を参考にしてください
マクロを選択

「MYBARCODECREATE」を選択し「実行」をクリックしてください
(「何列右にバーコードを作成しますか?」と聞かれますので、上の画像のように2列右に挿入したい場合は「2」と入力してください。「-2」と入力すると2列左にバーコードを挿入しようとしますが、A列より左は無いためエラーになります。「-1」と入力するとA列に挿入します)
バーコード挿入を実行

ここまでの手順をこなすと、下記のようにバーコードが挿入されると思います
完成図

以前にフリーソフトを使ったバーコードの作成方法を別のブログで紹介したことがあるのですが、パソコンや環境によっては使えないことがあるようでした。

今回紹介した方法なら、環境に関係無くエクセルだけでバーコードができるはずなので活用してみてください。
なお、当ブログの記事を用いることによって被った損害・損失に対しては一切の責任を負いかねますのであらかじめご了承下さい。

ちなみに「CHECK DIGIT ERROR」が出てきてバーコードが作成できない、という場合は下記のコードを使用してください。

チェックデジットがおかしい場合には、対象のJANコードのセルを青で塗りつぶします。

Option Explicit
Function CHECKDIGIT(ByVal target As Range) As String
    Dim strJAN As Integer
    Dim i As Integer
    Select Case Len(target)
        Case 12, 13
            i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
                CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
            i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
                CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
            strJAN = Right(10 - CInt(Right(i, 1)), 1)
            CHECKDIGIT = strJAN
        Case 7, 8
            i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
                + CInt(Mid(target, 7, 1))) * 3
            i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
            strJAN = Right(10 - CInt(Right(i, 1)), 1)
            CHECKDIGIT = strJAN
        Case Else
            Exit Function
    End Select
End Function
Sub MYBARCODECREATE()
    Application.ScreenUpdating = False
    Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
    Dim c As Range
    Dim mycode As String
    Dim myhdch As String
    Dim sh As Worksheet, shbar As Worksheet
    Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
    Dim h
    myheadchar13 = Array("aaaaaa", "aababb", "aabbab", "aabbba", "abaabb", "abbaab", "abbbaa", "ababab", "ababba", "abbaba")
    myleftodd13 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
    mylefteven13 = Array("2122111", "2112211", "2211211", "2122221", "2211121", "2111221", "2222121", "2212221", "2221221", "2212111")
    myrighteven13 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
    myleftodd8 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
    myrighteven8 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
    i = 0
    Set sh = ActiveSheet
    For Each c In Selection
        Select Case Len(c)
            Case 8, 13
            If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
                c.Interior.Color = 16711680
                i = i + 1
            End If
        End Select
    Next
    If IMEStatus <> vbIMEModeOff Then
        SendKeys "{kanji}"
    End If
    x = InputBox("何列右にバーコードを作成しますか?")
    Worksheets.Add
    ActiveSheet.Name = "mysh"
    Set shbar = Worksheets("mysh")
    Cells.Interior.Color = 16777215
    Cells.ColumnWidth = 0.08
    Rows("2:2").RowHeight = 15
    Rows("3:3").RowHeight = 4.5
    Rows("4:4").RowHeight = 4.5
    Cells.Font.Size = 6
    Range("Q3").NumberFormatLocal = "000000"
    Range("BL3").NumberFormatLocal = "000000"
    With Range("A3:K4")
        .Merge
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    With Range("Q3:BD4")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    With Range("BL3:CY4")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    Range("M2:M3").Merge
    Range("O2:O3").Merge
    Range("BG2:BG3").Merge
    Range("BI2:BI3").Merge
    Range("DA2:DA3").Merge
    Range("DC2:DC3").Merge
    Rows("6:6").RowHeight = 15
    Rows("7:7").RowHeight = 4.5
    Rows("8:8").RowHeight = 4.5
    Range("M6:M7").Merge
    Range("O6:O7").Merge
    Range("AS6:AS7").Merge
    Range("AU6:AU7").Merge
    Range("BY6:BY7").Merge
    Range("CA6:CA7").Merge
    With Range("Q7:AP8")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    .ShrinkToFit = True
    End With
    With Range("AX7:BW8")
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    Range("Q7").NumberFormatLocal = "0000"
    Range("AX7").NumberFormatLocal = "0000"
    sh.Activate
    For Each c In Selection
        If Len(c) = 12 Or Len(c) = 13 Then
            mycode = "222222222222121"
            myhdch = myheadchar13(Left(c, 1))
            For s = 2 To 7
                Select Case Mid(myhdch, s - 1, 1)
                    Case "a"
                        mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
                    Case "b"
                        mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
                End Select
            Next s
            mycode = mycode & "21212"
            For t = 8 To 12
                mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
            Next t
            mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
            mycode = mycode & "121222222222222"
            shbar.Range("A3").Value = Left(c, 1)
            shbar.Range("Q3").Value = Mid(c, 2, 6)
            shbar.Range("BL3").Value = Mid(c, 8, 5) & CHECKDIGIT(c)
            For w = 1 To Len(mycode)
                If Mid(mycode, w, 1) = 1 Then
                shbar.Cells(2, w).Interior.Color = 0
                End If
            Next w
            shbar.Range("A2:DO4").CopyPicture Appearance:=xlScreen, Format:=xlPicture
            c.Offset(, x).PasteSpecial
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = c.Height - 4
                .Width = c.Offset(0, x).Width - 4
                .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
                .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
            End With
            shbar.Cells.Interior.Color = 16777215
        End If
        If Len(c) = 7 Or Len(c) = 8 Then
            mycode = "222222222222121"
            For y = 1 To 4
                mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
            Next y
            mycode = mycode & "21212"
            For z = 5 To 7
                mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
            Next z
            mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
            mycode = mycode & "121222222222222"
            For p = 1 To Len(mycode)
                If Mid(mycode, p, 1) = 1 Then
                    shbar.Cells(6, p).Interior.Color = 0
                End If
            Next p
            shbar.Range("Q7") = Left(c, 4)
            shbar.Range("AX7") = Mid(c, 5, 3) & CHECKDIGIT(c)
            shbar.Range("A6:CM8").CopyPicture Appearance:=xlScreen, Format:=xlPicture
            c.Offset(, x).PasteSpecial
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = c.Height - 4
                .Width = c.Offset(0, x).Width - 4
                .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
                .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
            End With
            shbar.Cells.Interior.Color = 16777215
        End If
Next c
    MsgBox i & "個のJANコードは最終の桁(チェックデジット)が違っていました" & vbCrLf & "(青色塗りつぶしのセル)"
    Application.DisplayAlerts = False
        Worksheets("mysh").Delete
    Application.DisplayAlerts = True
End Sub
シェア頂けると嬉しいです!よろしくお願いします!
URLをコピーする
URLをコピーしました!
  • URLをコピーしました!

コメント

コメント一覧 (81件)

  • はじめまして。
    バーコード作成方法を探していてこちらにお邪魔させて頂きました。
    非常にわかりやすく、敷居の低いご説明ありがとうございました。
    大変に助かりました。

    tk

  • JANバーコードのみ(13桁数字なし)は可能でしょうか。

    お世話になったそばから大変に恐縮ですが。

    • 下記のコードで数字無しのバーコードができると思います
      ご活用ください

      Option Explicit
      Function CHECKDIGIT(ByVal target As Range) As String
      Dim strJAN As Integer
      Dim i As Integer
      Select Case Len(target)
      Case 12, 13
      i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
      CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
      i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
      CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case 7, 8
      i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
      + CInt(Mid(target, 7, 1))) * 3
      i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case Else
      Exit Function
      End Select
      End Function
      Sub MYBARCODECREATE()
      Application.ScreenUpdating = False
      Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
      Dim c As Range
      Dim mycode As String
      Dim myhdch As String
      Dim sh As Worksheet, shbar As Worksheet
      Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
      Dim h
      myheadchar13 = Array(“aaaaaa”, “aababb”, “aabbab”, “aabbba”, “abaabb”, “abbaab”, “abbbaa”, “ababab”, “ababba”, “abbaba”)
      myleftodd13 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      mylefteven13 = Array(“2122111”, “2112211”, “2211211”, “2122221”, “2211121”, “2111221”, “2222121”, “2212221”, “2221221”, “2212111”)
      myrighteven13 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      myleftodd8 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      myrighteven8 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      i = 1
      Set sh = ActiveSheet
      For Each c In Selection
      Select Case Len(c)
      Case 8, 13
      If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
      c.Interior.Color = 16711680
      MsgBox “CHECK DIGIT ERROR” & vbCrLf & c.Address(False, False)
      i = i + 1
      End If
      If i > 1 Then
      Exit Sub
      End If
      End Select
      Next
      x = InputBox(“column (-100~100)”)
      Worksheets.Add
      ActiveSheet.Name = “mysh”
      Set shbar = Worksheets(“mysh”)
      Cells.Interior.Color = 16777215
      Cells.ColumnWidth = 0.08
      Rows(“2:2”).RowHeight = 15
      Rows(“3:3”).RowHeight = 4.5
      Rows(“4:4”).RowHeight = 4.5
      Cells.Font.Size = 6
      Range(“Q3”).NumberFormatLocal = “000000”
      Range(“BL3”).NumberFormatLocal = “000000”
      With Range(“A3:K4”)
      .Merge
      .HorizontalAlignment = xlRight
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“Q3:BD4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“BL3:CY4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“M2:M3”).Merge
      Range(“O2:O3”).Merge
      Range(“BG2:BG3”).Merge
      Range(“BI2:BI3”).Merge
      Range(“DA2:DA3”).Merge
      Range(“DC2:DC3”).Merge
      Rows(“6:6”).RowHeight = 15
      Rows(“7:7”).RowHeight = 4.5
      Rows(“8:8”).RowHeight = 4.5
      Range(“M6:M7”).Merge
      Range(“O6:O7”).Merge
      Range(“AS6:AS7”).Merge
      Range(“AU6:AU7”).Merge
      Range(“BY6:BY7”).Merge
      Range(“CA6:CA7”).Merge
      With Range(“Q7:AP8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“AX7:BW8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“Q7”).NumberFormatLocal = “0000”
      Range(“AX7”).NumberFormatLocal = “0000”
      sh.Activate
      For Each c In Selection
      If Len(c) = 12 Or Len(c) = 13 Then
      mycode = “222222222222121”
      myhdch = myheadchar13(Left(c, 1))
      For s = 2 To 7
      Select Case Mid(myhdch, s – 1, 1)
      Case “a”
      mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
      Case “b”
      mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
      End Select
      Next s
      mycode = mycode & “21212”
      For t = 8 To 12
      mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
      Next t
      mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      ‘shbar.Range(“A3”).Value = Left(c, 1)
      ‘shbar.Range(“Q3”).Value = Mid(c, 2, 6)
      ‘shbar.Range(“BL3”).Value = Mid(c, 8, 5) & CHECKDIGIT(c)
      For w = 1 To Len(mycode)
      If Mid(mycode, w, 1) = 1 Then
      shbar.Cells(2, w).Interior.Color = 0
      End If
      Next w
      shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      If Len(c) = 7 Or Len(c) = 8 Then
      mycode = “222222222222121”
      For y = 1 To 4
      mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
      Next y
      mycode = mycode & “21212”
      For z = 5 To 7
      mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
      Next z
      mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      For p = 1 To Len(mycode)
      If Mid(mycode, p, 1) = 1 Then
      shbar.Cells(6, p).Interior.Color = 0
      End If
      Next p
      ‘shbar.Range(“Q7”) = Left(c, 4)
      ‘shbar.Range(“AX7”) = Mid(c, 5, 3) & CHECKDIGIT(c)
      shbar.Range(“A6:CM8”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      Next c
      Application.DisplayAlerts = False
      Worksheets(“mysh”).Delete
      Application.DisplayAlerts = True
      End Sub

      • バーコードを表示させたまま他のPCに渡せるEXCELを生成する方法を探し、こちらの方法を利用させていただきました。EXCELのみで、簡単に実現でき、本当に有りがたく思っております。
        ご紹介いただいた数字なしバージョンのコードについて、Internet Explorer 11からEXCEL2013のVBAモジュールにコピー・ペーストすると、シングル・ダブルクォーテーションが全角に、マイナス記号がクエスチョン記号になり、修正が必要でした。
        おそらく自動的なエスケープ処理の結果と思います。愚見ながら申し添えます。

        • アドバイスいただきありがとうございます。
          私のスキルでは様々なPCの環境に対応させることは難しいかもしれませんが、ご指摘いただいたことを記憶しておき、少しでもみなさんが使いやすいようにしていきます。

  • はじめまして。
    仕事でJANコードを印刷した商品リストを作る必要があり、こちらでご紹介頂いた方法で試したところ、バッチリでした。
    ありがとうございました。

  • はじめまして。
    凄く判りやすくて、感激です。
    ありがとうございましたm(_”_)m

  • はじめまして、自店舗の価格表作成に大変重宝させていただいております。
    一点お伺いしたいのですが、0から始まるインストアコードのバーコード画像変換は
    出来なかったのですが何か解決する方法はございますでしょうか?

    お忙しいところ、申し訳ありませんがご教授頂ければ幸いです。

    • 遅くなりまして申し訳ありません。
      セルの表示形式を「文字列」にして、先頭の文字は「0」になっているでしょうか?
      セルの値は、見た目の値と実際の値が異なっていることがありますので、その点を確かめてみてください。

  • 初めまして。
    仕事でJANコードを入れた表を作成したくて、お邪魔しました。
    初心者でも分かりやすく教えていただいてありがとうございます。
    只、たびたびエラー1004が出てしまうのですが、原因は何でしょうか。
    教えていただければと思います。

    • 返信遅くなりまして申し訳ありません。
      エラー1004を調べてみたところ、様々な状況で出るようです。
      どういった内容のメッセージが出るのかも教えていただければ幸いです。
      なお、私はスキルがそれほど高くないので、解決できないことも結構あると思いますので、その点はあらかじめご了承ください。

  • とてもわかりやすい記事をありがとうございます。
    officeforMacのExcelを利用していますが、
    記載のコードでバーコード画像を一括挿入することができました。
    ただ、マクロで自動挿入される画像のサイズがかなり小さいです(縦が短く幅広)。
    セルのサイズを拡大した上でマクロを実行すると、
    自動挿入の画像も自動拡大となりますが、文字や線がぼやけてします。
    挿入の際のサイズを一定にして、画像がぼやけないようにしたいのですが、可能でしょうか?
    VBAマクロ、本当に初心者なもので、教えていただければ幸いです。
    お忙しいところ恐縮ですが、よろしくお願い致します。

    • こんにちは
      macは触ったことがないのでどのような原因か分からないのですが、バーコードの元画像を10倍サイズで作るコードを下記に記載しておきます。
      ちなみにコメントのところを変えると調整できます
      試してみてください。

      Option Explicit
      Function CHECKDIGIT(ByVal target As Range) As String
      Dim strJAN As Integer
      Dim i As Integer
      Select Case Len(target)
      Case 12, 13
      i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
      CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
      i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
      CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case 7, 8
      i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
      + CInt(Mid(target, 7, 1))) * 3
      i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case Else
      Exit Function
      End Select
      End Function
      Sub MYBARCODECREATE_formac()
      Application.ScreenUpdating = False
      Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
      Dim c As Range
      Dim mycode As String
      Dim myhdch As String
      Dim sh As Worksheet, shbar As Worksheet
      Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
      Dim h
      myheadchar13 = Array(“aaaaaa”, “aababb”, “aabbab”, “aabbba”, “abaabb”, “abbaab”, “abbbaa”, “ababab”, “ababba”, “abbaba”)
      myleftodd13 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      mylefteven13 = Array(“2122111”, “2112211”, “2211211”, “2122221”, “2211121”, “2111221”, “2222121”, “2212221”, “2221221”, “2212111”)
      myrighteven13 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      myleftodd8 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      myrighteven8 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      i = 1
      Set sh = ActiveSheet
      For Each c In Selection
      Select Case Len(c)
      Case 8, 13
      If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
      c.Interior.Color = 16711680
      MsgBox “CHECK DIGIT ERROR” & vbCrLf & c.Address(False, False)
      i = i + 1
      End If
      If i > 1 Then
      Exit Sub
      End If
      End Select
      Next
      x = InputBox(“column (-100~100)”)
      Worksheets.Add
      ActiveSheet.Name = “mysh”
      Set shbar = Worksheets(“mysh”)
      Cells.Interior.Color = 16777215
      Cells.ColumnWidth = 0.8 ‘・・・列の幅(JAN8・JAN13共通)
      Rows(“2:2”).RowHeight = 150 ‘・・・メインとなるバーコードの高さ(JAN13)
      Rows(“3:3”).RowHeight = 45 ‘・・・センター(と両端)のバーコードの高さ(JAN13)
      Rows(“4:4”).RowHeight = 45 ‘・・・両端のバーコードの高さ(JAN13)
      Cells.Font.Size = 60 ‘・・・文字のサイズ(JAN8・JAN13共通)
      Range(“Q3”).NumberFormatLocal = “000000”
      Range(“BL3”).NumberFormatLocal = “000000”
      With Range(“A3:K4”)
      .Merge
      .HorizontalAlignment = xlRight
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“Q3:BD4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“BL3:CY4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“M2:M3”).Merge
      Range(“O2:O3”).Merge
      Range(“BG2:BG3”).Merge
      Range(“BI2:BI3”).Merge
      Range(“DA2:DA3”).Merge
      Range(“DC2:DC3”).Merge
      Rows(“6:6”).RowHeight = 150 ‘・・・メインとなるバーコードの高さ(JAN8)
      Rows(“7:7”).RowHeight = 45 ‘・・・センター(と両端)のバーコードの高さ(JAN8)
      Rows(“8:8”).RowHeight = 45 ‘・・・両端のバーコードの高さ(JAN13)
      Range(“M6:M7”).Merge
      Range(“O6:O7”).Merge
      Range(“AS6:AS7”).Merge
      Range(“AU6:AU7”).Merge
      Range(“BY6:BY7”).Merge
      Range(“CA6:CA7”).Merge
      With Range(“Q7:AP8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“AX7:BW8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“Q7”).NumberFormatLocal = “0000”
      Range(“AX7”).NumberFormatLocal = “0000”
      sh.Activate
      For Each c In Selection
      If Len(c) = 12 Or Len(c) = 13 Then
      mycode = “222222222222121”
      myhdch = myheadchar13(Left(c, 1))
      For s = 2 To 7
      Select Case Mid(myhdch, s – 1, 1)
      Case “a”
      mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
      Case “b”
      mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
      End Select
      Next s
      mycode = mycode & “21212”
      For t = 8 To 12
      mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
      Next t
      mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      shbar.Range(“A3”).Value = Left(c, 1)
      shbar.Range(“Q3”).Value = Mid(c, 2, 6)
      shbar.Range(“BL3”).Value = Mid(c, 8, 5) & CHECKDIGIT(c)
      For w = 1 To Len(mycode)
      If Mid(mycode, w, 1) = 1 Then
      shbar.Cells(2, w).Interior.Color = 0
      End If
      Next w
      shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      If Len(c) = 7 Or Len(c) = 8 Then
      mycode = “222222222222121”
      For y = 1 To 4
      mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
      Next y
      mycode = mycode & “21212”
      For z = 5 To 7
      mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
      Next z
      mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      For p = 1 To Len(mycode)
      If Mid(mycode, p, 1) = 1 Then
      shbar.Cells(6, p).Interior.Color = 0
      End If
      Next p
      shbar.Range(“Q7”) = Left(c, 4)
      shbar.Range(“AX7”) = Mid(c, 5, 3) & CHECKDIGIT(c)
      shbar.Range(“A6:CM8”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      Next c
      Application.DisplayAlerts = False
      Worksheets(“mysh”).Delete
      Application.DisplayAlerts = True
      End Sub

      • 確認が遅く、お礼が遅くなってしまい失礼いたしました。
        丁寧にご教示いただき、ありがとうございます。早速試してみます。

  • このコードを入れて実行するとこのようなエラーが出るのですが、どう対処すればよいでしょうか。

    実行時エラー 1004 RangeクラスのPasteSpecialメソッドが失敗しました。

    ディバックを押すと c.Offset(, x).PasteSpecialの部分が黄色く光ります。

    • こんにちは
      エラーを回避するためにちょっとだけコードを足してみましたので、下記のコードを貼り付けて再度試してください。
      ちなみにそれでもエラーが出る場合には私の知識では対処できない可能性も高いので、その点についてはあらかじめご了承ください

      Option Explicit
      Function CHECKDIGIT(ByVal target As Range) As String
      Dim strJAN As Integer
      Dim i As Integer
      Select Case Len(target)
      Case 12, 13
      i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
      CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
      i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
      CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case 7, 8
      i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
      + CInt(Mid(target, 7, 1))) * 3
      i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
      strJAN = Right(10 – CInt(Right(i, 1)), 1)
      CHECKDIGIT = strJAN
      Case Else
      Exit Function
      End Select
      End Function
      Sub MYBARCODECREATE_151026()
      Application.ScreenUpdating = False

      Application.EnableEvents = False

      Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
      Dim c As Range
      Dim mycode As String
      Dim myhdch As String
      Dim sh As Worksheet, shbar As Worksheet
      Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
      Dim h
      myheadchar13 = Array(“aaaaaa”, “aababb”, “aabbab”, “aabbba”, “abaabb”, “abbaab”, “abbbaa”, “ababab”, “ababba”, “abbaba”)
      myleftodd13 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      mylefteven13 = Array(“2122111”, “2112211”, “2211211”, “2122221”, “2211121”, “2111221”, “2222121”, “2212221”, “2221221”, “2212111”)
      myrighteven13 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      myleftodd8 = Array(“2221121”, “2211221”, “2212211”, “2111121”, “2122211”, “2112221”, “2121111”, “2111211”, “2112111”, “2221211”)
      myrighteven8 = Array(“1112212”, “1122112”, “1121122”, “1222212”, “1211122”, “1221112”, “1212222”, “1222122”, “1221222”, “1112122”)
      i = 1
      Set sh = ActiveSheet
      For Each c In Selection
      Select Case Len(c)
      Case 8, 13
      If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
      c.Interior.Color = 16711680
      MsgBox “CHECK DIGIT ERROR” & vbCrLf & c.Address(False, False)
      i = i + 1
      End If
      If i > 1 Then
      Exit Sub
      End If
      End Select
      Next
      x = InputBox(“column (-100~100)”)
      Worksheets.Add
      ActiveSheet.Name = “mysh”
      Set shbar = Worksheets(“mysh”)
      Cells.Interior.Color = 16777215
      Cells.ColumnWidth = 0.08
      Rows(“2:2”).RowHeight = 15
      Rows(“3:3”).RowHeight = 4.5
      Rows(“4:4”).RowHeight = 4.5
      Cells.Font.Size = 6
      Range(“Q3”).NumberFormatLocal = “000000”
      Range(“BL3”).NumberFormatLocal = “000000”
      With Range(“A3:K4”)
      .Merge
      .HorizontalAlignment = xlRight
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“Q3:BD4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“BL3:CY4”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“M2:M3”).Merge
      Range(“O2:O3”).Merge
      Range(“BG2:BG3”).Merge
      Range(“BI2:BI3”).Merge
      Range(“DA2:DA3”).Merge
      Range(“DC2:DC3”).Merge
      Rows(“6:6”).RowHeight = 15
      Rows(“7:7”).RowHeight = 4.5
      Rows(“8:8”).RowHeight = 4.5
      Range(“M6:M7”).Merge
      Range(“O6:O7”).Merge
      Range(“AS6:AS7”).Merge
      Range(“AU6:AU7”).Merge
      Range(“BY6:BY7”).Merge
      Range(“CA6:CA7”).Merge
      With Range(“Q7:AP8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      With Range(“AX7:BW8”)
      .Merge
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .ShrinkToFit = True
      End With
      Range(“Q7”).NumberFormatLocal = “0000”
      Range(“AX7”).NumberFormatLocal = “0000”
      sh.Activate
      For Each c In Selection
      If Len(c) = 12 Or Len(c) = 13 Then
      mycode = “222222222222121”
      myhdch = myheadchar13(Left(c, 1))
      For s = 2 To 7
      Select Case Mid(myhdch, s – 1, 1)
      Case “a”
      mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
      Case “b”
      mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
      End Select
      Next s
      mycode = mycode & “21212”
      For t = 8 To 12
      mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
      Next t
      mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      shbar.Range(“A3”).Value = Left(c, 1)
      shbar.Range(“Q3”).Value = Mid(c, 2, 6)
      shbar.Range(“BL3”).Value = Mid(c, 8, 5) & CHECKDIGIT(c)
      For w = 1 To Len(mycode)
      If Mid(mycode, w, 1) = 1 Then
      shbar.Cells(2, w).Interior.Color = 0
      End If
      Next w
      shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      If Len(c) = 7 Or Len(c) = 8 Then
      mycode = “222222222222121”
      For y = 1 To 4
      mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
      Next y
      mycode = mycode & “21212”
      For z = 5 To 7
      mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
      Next z
      mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
      mycode = mycode & “121222222222222”
      For p = 1 To Len(mycode)
      If Mid(mycode, p, 1) = 1 Then
      shbar.Cells(6, p).Interior.Color = 0
      End If
      Next p
      shbar.Range(“Q7”) = Left(c, 4)
      shbar.Range(“AX7”) = Mid(c, 5, 3) & CHECKDIGIT(c)
      shbar.Range(“A6:CM8”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
      c.Offset(, x).PasteSpecial
      With Selection
      .ShapeRange.LockAspectRatio = msoFalse
      .Height = c.Height – 4
      .Width = c.Offset(0, x).Width – 4
      .Left = c.Offset(0, x).Left + (c.Offset(0, x).Width – .Width) / 2
      .Top = c.Offset(0, x).Top + (c.Offset(0, x).Height – .Height) / 2
      End With
      shbar.Cells.Interior.Color = 16777215
      End If
      Next c
      Application.DisplayAlerts = False
      Worksheets(“mysh”).Delete
      Application.DisplayAlerts = True

      Application.EnableEvents = True

      End Sub

      • 突然、 RangeクラスのPasteSpecialメソッドが失敗しました。
        ディバックを押すと c.Offset(, x).PasteSpecialの部分が黄色く光ります。といったエラー状態が出現しました。2年近く利用して全く問題ありませんでした。原因は不明ですがこの修正コードで救われました。ー(マイナス)が全角なので赤くなりますが-マイナス(半角)なら問題なく利用可能です。
        問題は私のPCの場合は、バーコードは1000点でもできるのですが、貼り付けるのに500点で切り捨てられることです。
        別に有料でもいいのでちゃんとしたバーコード作成ソフトがあるといいです。発注書を作成するのにヒヤヒヤです。

        • やはりだめでした。バーコード作成できませんでした。
          バーコード作成ソフトを探します。

          • ※コメントを見てる方へ
            メール等でやり取りしていましたが、最終的に解決ができませんでした。

  • はじめまして。
    超丁寧解説、ありがとうございます。

    質問です。
    こちらは、
    code128 コードC
    には、対応しますでしょかう?

    よろしくお願いいたします。

    • こんにちは
      申し訳ありませんが、こちらの記事のコードではJANコードとEANコードしか作れません。
      現在Mibarcdというフリーソフトとエクセルで一括作成する記事を書いておりまして、近日(おおむねか1ヶ月以内)公開できるかと思います。
      Mibarcdで作れるバーコードは全て作れるようになると思いますので、その記事がアップされましたらそちらをお使いください。

      • ご回答ありがとうございます。
        了解でございます。

        > 現在Mibarcdというフリーソフトとエクセル...
        期待しております。

        よろしくお願いいたします。

  • はじめまして。JANコードをバーコードに一括変換できました。
    助かりました。ありがとうございます。ひとつ質問があります。
    A4サイズに印刷するときに、バーコードと商品名だけを縦に2列に又は、3列に並べることはできますか?
    1列だと行番号が500以上もあるので数十ページにもなります
    効率の良い並べ方を教えて頂けないでしょうか。
    ワードの段組みのようにしたいのですが、エクセルでも簡単に出来ますか?。
    操作方法がわかりません。よろしくお願いします。

    • こんにちは
      下記リンクに記事をアップしました。
      http://nanameue-news.com/2015/11/08/471/
      ワードの段組みをイメージされているようですので、そのままワードでの段組みでの印刷方法を紹介しています。
      ご活用ください。

  • とてもわかりやすかったです!
    QRコード2のやり方があればぜひ教えてください!

    • こんにちは
      フリーソフトを使って一括でQR2も作れる記事を近日アップする予定です。
      11月中にはアップする予定ですので、そちらをご利用ください。

  • 3千個のJANに対して、実行したら、5分間をたったまま、今だにアイドル状態になりました。
    メモリコントロールか、処理をもっと軽くするか、どうしたら宜しいでしょうか。
    (数少ないJANに対しては、うまく対応出来てます)

    • 追記です。
      3000個JANの場合、8分をかかりました。
      MAC環境Office 2011 でちゃんと動きます。
      ありがとうございました。

      • 使用例含めてのご報告ありがとうございます。
        処理を軽くする等の方法は私の知識では中々難しいかと思いますので、あしからずご了承ください。

        • 初めまして
          エクセル2013でマクロを実行したところコンパイルエラーと表記されました
          Sub MYBARCODECREATE()
          の部分が黄色くなっています。

          対処方法はございますでしょうか

          • こんにちは
            ちょっと解決できるかどうは分からないのですが・・・
            おそらく「コンパイルエラー」以外にも何がしかメッセージが出てると思います。
            それを教えていただけますか?
            ちなみに個人的なことなのですが、年度末の月末でかなり忙しいため返信が遅れる可能性が高いので、申し訳ありませんが悪しからずご了承ください。

        • いつもご丁寧に回答頂き、ありがとうございました。
          結構使いやすいプログラムです。
          何度もたすかりました。
          ありがとうございます。

        • 3000個JANは作成できました。しかし、EXCELに貼り付けると図が大きすぎて切り捨てられるとのメッセージがでて387個しか貼り付けができません。10回にわけて貼り付けるしか手段はないのでようか。

        • JAN3000個のバーコードができました。私の使用しているフリーソフトでは、実際2時間以上かかりますので、このソフトの方が何回か分けて貼り付けることができるので大変助かります。しかし、もっと効率的にバーコードを作成する手段がないのでしょうか。アクセスを利用しても結局同じ状態になるのでしょうか。

  • はじめて本格的なマクロに挑戦しました。
    指南通りに実行したところ、無事バーコードの画像が生成されました。

    社内で導入するにあたり、稼働をかけず、安全に確実にシンプルに管理する手法としては素晴らしいマクロの記述方法かと思います。

    ありがとうございました。

  • コード5ケタでも バーコードを作成したいのですが、どうすればよいでしょうか

  • 当方マクロ等は素人だったのですが、斜め上ニュース管理人様のレクチャーでJAN/EANコードを作成することができました!ですが、仕事上どうしてもエクセルのマクロのみ(先日ご紹介いただいた”MiBarcode”等も使用せずに)でcode128のバーコードを作成できればと考えているのですが、斜め上ニュース管理人様の方で作成いただけないでしょうか?また、レクチャーいただけないでしょうか?不躾な質問・要望で申し分けございません。ご容赦ください。

  • 上記コードを埋め込みマクロを実行したのですが、
    コンパイルエラー:変数が定義されていません。
    というエラーが出てきてしまいます。

    見ると、
    Sub MYBARCODECREATE()
    が黄色くなり、
    msoFalse
    が青くなっています。

    これは何が原因なのでしょうか?

    • おパパさんへ
      コードの1行目の「Option Explicit」を削除して実行するとどうなるでしょうか?

  • バーコードを3000点2~3分で作成できました。しかし、EXCELに貼り付けると画像が大きすぎるとのメッセージがでて400個くらいしか貼り付けができません。しかし、現在利用しているフリーソフトでは作成に2時間くらいかかります。分割して貼り付けてもこのソフトのほうが大変助かります。ありがとうございました。しかし、実際は7000点近くになることを想定して、バーコードを一括で大量に作成貼り付けのできるソフトがひつようです。アクセスを利用しても同じでしょうか。

    • 斜め上の管理人様
      EXCEL2007以上のファイル同士であれば2000点でも作成に6~7分、貼り付けて1分でバーコードを作成できました。ありがとうございました。いままでの手間は一体何だったんでしょうか。これで
      なんとか利用できることを確信しました。
      問題点
      1リセットがVBAできないか
      2文字列も貼り付けできないか
      以上2点ができれば非常に良いソフトであると思います。

  • 初めまして。仕事でJANコードの数字はあるものの、バーコードがない商品にバーコードをつける目的で、こちらのサイトのプログラムを利用させて頂こうと思っているのですが
    13桁の数字を打ち込み、指示通りの方法でやってみたのですが、
    CHECK DIGIT ERROR A2(数字は打ち込んだ列の数字です。)というメッセージがでてしまいます。

    考えられる問題点があれば、教えて頂ければ幸いです。
    お忙しいところ申し訳ありませんが、よろしくお願いいたします。

    • 初めまして
      斜め上ニュースの管理人です。
      「CHECK DIGIT ERROR」が出るということは、8桁・13桁のJANコードの数値がおかしい可能性が高いです。
      詳しい説明は省きますが、13桁のJANコードの場合ですと、12桁のデータ+数字(チェックデジットといい、計算で求められます)で13桁となります。
      13桁目の数値は計算で求められる数値以外は無効となりますが、その数値がおかしい可能性が高いです。
      「CHECK DIGIT ERROR」のあとに「A2」と出るのは、エクセルのセル「A2」のJANコードがおかしい可能性が高いです。

      • お忙しいところ、返信ありがとうございます。打ち込んでいる13桁の数字は、実際の商品のJANコードの数字を入力しています。
        ちゃんとにバーコードに変換されるものもあれば、前記述のerrorがでるものもあって、その違いが全く解らず ご連絡差し上げた次第です。

        打ち込んでいるJANコードが正しい場合は、入力するセルの設定の問題でしょうか?
        度々申し訳ありません。

  • 6桁ほどの数字列でバーコードを作成することは可能でしょうか???
    初心者ですので、頼り切りになりそうですが、申し訳ないです。

  • 困っているたのですが、こちらのサイトのおかげで大変助かりました!
    技術に感動です。ありがとうございました!

  • EXCELの商品リストにバーコードを表示させるべく、
    いろいろ試してみましたが、
    こちらのツールが、まさに「俺のやりたいことはこれだよ」
    って感じで、バッチリでした。
    ありがとうございます。

  • こんにちは

    商品リストのJANを他のシートへバーコードとして貼り付けをしたいのですが、
    何か方法はございますか?

    宜しくお願い致します。

    • **********************************************************************
      商品リストのJANを他のシートへバーコードとして貼り付けをしたいのですが、
      何か方法はございますか?
      **********************************************************************

      とのことですが、おそらく可能だと思います。
      (あくまでも、使い方を想像すると、こういう使い方かな?と思う範囲で)
      ただ、それ専用にプログラムを変更しないとできません。
      必要な情報としましては、とりあえず下記となります。

      ■商品リストのシートのシート名(大文字・小文字・半角・全角を含めた正確なシート名が欲しいです)
      ■商品リストのシートのどのセル(B2とかC3とか)からJANコードが入っているか
      ■他のシート(バーコードを張り付けるシート)のシート名(大文字・小文字・半角・全角を含めた正確なシート名が欲しいです)
      ■他のシート(バーコードを張り付けるシート)のどのセル(B2とかC3とか)からバーコードを入れるか

      または、簡単な方法としましては、JANコードを一旦バーコードを張り付けたいシートに貼り付けまたは挿入してバーコードを作り、JANコードを範囲かまたは列ごと削除するという方法です。

      プログラムを変更して使う場合、セルの位置や列構成が変わると使えなくなります。

      どのような使い方かを具体的に教えていただければ、より具体的なアドバイスができるかと思います。

      • 早速の御返事ありがとうございます。

        使い方としては商品リストを作成し、そこからJAN付のプライスカードを作成したいと考えています。

        シート1で作成した商品リスト50列分の情報を、A4サイズ2枚に並ぶマッチ箱サイズのプライスカード横列5ヶ、縦列5ヶ 計50枚のプライスカードをシート2へ作成したいです。(文字は全てVlookupで引いています)

        現状貴方にご教授いただいた方法を用い、一度シート1の商品リストへJANを作成後、手作業でシート2のプライスカードへコピー&ペーストしております。

        もし手作業ではなく簡単にできたらなと思い問い合わせ致しました。
        伝わりにくく申し訳ありません、何卒宜しくお願い致します。

        • こんばんは
          使い方は分かりました。
          ちょっと作ってみますので(時間は掛かりますが)、必要な情報をください。

          ■シート1・シート2のシート名(大文字・小文字・半角・全角を含めた正確なシート名が欲しいです)
          ■シート1のどのセルにJANコードが入っているか(C2~C51など)
          ■シート2のどのセルにバーコードを入れるかを知りたいです。始めの6個と終わりの6個のセルを順番も含めて教えてください。(お手間なのですが、できれば全てのセルを知りたいです)

          なお、私はサラリーマンをしているので、あまり時間を取れません。
          結構時間が掛かると思いますので、あらかじめご了承ください。

          • お忙しいのにありがとうございます。

            ■シート1・シート2のシート名(大文字・小文字・半角・全角を含めた正確なシート名が欲しいです)

            ⇒商品マスタ と プライスカード

            ■シート1のどのセルにJANコードが入っているか(C2~C51など)

            ⇒C3~C52

            ■シート2のどのセルにバーコードを入れるかを知りたいです。始めの6個と終わりの6個のセルを順番も含めて教えてください。(お手間なのですが、できれば全てのセルを知りたいです)

            ⇒C8、I8、O8、U8、AA8
             C16、I16、U16、AA16
             C24、I24、U24、AA24
             C32、I32、U32、AA32
             C40、I40、U40、AA40
             C48、I48、U48、AA48
             C56、I56、U56、AA56
             C64、I64、U64、AA64
             C72、I72、U72、AA72
             C80、I80、U80、AA80

            お手数おかけしますが、何卒宜しくお願い致します。

          • すいません、抜けがございました。
            再送いたします

            ■シート2のどのセルにバーコードを入れるかを知りたいです。始めの6個と終わりの6個のセルを順番も含めて教えてください。(お手間なのですが、できれば全てのセルを知りたいです)

            ⇒C8、I8、O8、U8、AA8
             C16、I16、O16、U16、AA16
             C24、I24、O24、U24、AA24
             C32、I32、O32、U32、AA32
             C40、I40、O40、U40、AA40
             C48、I48、O48、U48、AA48
             C56、I56、O56、U56、AA56
             C64、I64、O64、U64、AA64
             C72、I72、O72、U72、AA72
             C80、I80、U80、U80、AA80

          • 情報ありがとうございます。
            ちょっと作ってみますので、気長にお待ちいただけたらと思います。

          • 大変お待たせしました。
            下記リンク先のコードを試してください。

  • 有意義なデータを公開いただき、ありがとうございます。
    実行しましたが、以下のエラーとなりスタート時点で止まってしまいました。
    何か対応策はありますでしょうか。

    ===============================================
    実行時エラー ’5′:
    プロシージャの呼び出し、または引数が無効です。
    ===============================================

    デバッグを開くと
    Sub MYBARCODECREATE()から数えて28行目の
    SendKeys “{kanji}”
    の部分が黄色くなって止まっています。

    よろしくお願いいたします。

    • こんにちは
      下記の部分を削除して実行してみてください。

      If IMEStatus <> vbIMEModeOff Then
      SendKeys “{kanji}”
      End If

      その際には、「何列右にバーコードを作成しますか?」というボックスに数字を入力した後、OKのボタンは押さずに、キーボードのEnterを押して実行してください。

  • すぐに使える分かりやすい説明ですごく助かりました。
    ばっちりしたいことができました。
    ありがとうございます!

  • 質問を失礼いたします。
    オリジナルのバーコードを作成したいため、チェックディジットのエラーを検査せず、入力された数字をそのままバーコードにしたいのですがそのようなコードは作成可能なのでしょうか。
    例えば
    1000000000001
    をチェックディジットなしでそのままバーコードとしたいです。

    • この記事では「JANコード」を作成する方法を紹介していますが、「CODE128」(のコードセットB)というバーコードの形式であれば可能です。
      下記リンク先の記事を参考にしてください。
      http://nanameue-news.com/2017/01/01/799/

      ちなみに、バーコードリーダーの性能次第では、CODE128のバーコードが読み取れない可能性もありますので、留意ください。

  • こんばんは

    Excelシートに記載された数値からJANコードを作成したく、このサイトにたどり着きました

    斜め上ニュースさんが掲示しているVBAによるJANコード作成が、一番処理も早く私の希望に合致した仕様なのですが、137行目の
    shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture

    この部分で処理がエラーになってしまいます

    >エラーを回避するためにちょっとだけコードを足してみましたので

    この部分を利用させていただきましたが、これでも同じ場所で止まってしまいます

    ただ、エラーにならずに正常に動作する事もあるのです

    作成するJANコードの元データが2行程度なら大丈夫のようなのですが、4行以上になると止まってしまう傾向が出てきます

    私の場合、最大でも30~40程度の数値をJANコード表示させたいのですが、原因や対策はお分かりになるでしょうか?

    OSはWindows10 Excelのバージョンは2003 2013で行いましたが、どちらのバージョンの場合でも同じように
    shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    部分でエラーとなって止まってしまいます

    よろしくお願い致します

    • tamaiさん、こんばんは
      初めて聞く症状です。
      ちょっと調べてみますので、数日お時間をください。
      解決できるかどうかは分かりませんが・・

      • よろしくお願い致します

        コードの
        Next w
        shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture

        部分の間に
        On Error Resume Next
        を追加して

        Next w
        On Error Resume Next
        shbar.Range(“A2:DO4”).CopyPicture Appearance:=xlScreen, Format:=xlPicture

        としてやると、エラーにならずに最終行まで処理が済むのですが、途中途中でバーコードが作成されずに、空白となる行が発生してしまいます

        再生したバーコードの画像のコピー&ペーストの処理が間に合わずにエラーになってしまうって感じなのでしょうか

        • まだ解決できていないのですが、処理が間に合ってないのではなく、画像としてコピーできていない感じだと思います。
          もうちょっと時間をください。

          • すいません。今週は全く時間がとれませんでした。
            申し訳ありませんが、もう少し時間をください。

  • こんにちは
    On Error Resume Next
    を入力してやれば、バーコードが作成されない部分が出来ますがエラー表示はされずに最後まで処理は行えています

    バーコードが作成されない部分は、もう一度JANコードのセルを選択してバーコード作成させれば表示されるようになるので、管理人さんが作成して頂いたコードでやりたい事は行えていますので、急いでいる訳ではありません

    逆に何もインストールできない環境下で作成して頂いたコードで、JANのバーコードが作成できるようになっただけでもありがたいです

    • こんにちは。色々調べてみたのですが、同様の症状が起こる事例が見つけられず、私のスキルが低いこともあり、解決できそうもありません。お待たせしてしまったことと合わせまして、誠に申し訳ありません。

    • こんにちは。最近時間が無くて返信できてなくて申し訳ありません。今週末は少し時間ができる予定ですので、少々お待ちください。

    • エラーのでたJANコードをいくつか教えていただけますでしょうか。

コメントする

目次
閉じる