CODE128(コードセットBの数字・アルファベット・記号のみ)をエクセルだけで作る方法

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

CODE128(コード128)のコードセットBのバーコードをエクセルだけで作る方法を紹介します。

具体的には、下図の数値0から94までを表現できます。

以前、JANコードをエクセルのみで作る方法MiBarcodeというフリーソフトを使って色々なバーコードを作る方法を紹介したことがありますが、「CODE128をエクセルだけで作る方法が知りたい」という要望がありました。
調べてみると、CODE128にはA・B・Cの3種類がありかなり難しい印象でしたが、要望を具体的に聞くと、CODE128のコードセットBだけで大丈夫だということでしたので、なんとか作成してみました。

作成したついでに、似たような使い方をする人がいるかもしれないので記事にしておきます。

下記のような表に一括でバーコード画像を作成します。


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

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

「挿入」をクリック

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

すると右側に大きな白いスペースが現れたと思います
※↓画像の赤枠部分

このスペースに以下のコードをコピペしてください
(右下の「1クリックでコードをコピー」をクリックしてください)

Function IndexNumber(Target1, Target2)
    Dim i As Integer
    For i = 0 To UBound(Target1)
        If Target1(i) = Target2 Then Exit For
    Next
    IndexNumber = i
End Function
Sub CODE128_B()
    Application.ScreenUpdating = False
    Dim textcode, mynumber As Variant
    Dim mycode As String
    Dim c As Range
    Dim i, a, q, x, y, m As Integer
    Dim t As Double
    Dim shbar, sh As Worksheet
    textcode = Array(212222, 222122, 222221, 121223, 121322, 131222, 122213, 122312, 132212, _
                    221213, 221312, 231212, 112232, 122132, 122231, 113222, 123122, 123221, _
                    223211, 221132, 221231, 213212, 223112, 312131, 311222, 321122, 321221, _
                    312212, 322112, 322211, 212123, 212321, 232121, 111323, 131123, 131321, _
                    112313, 132113, 132311, 211313, 231113, 231311, 112133, 112331, 132131, _
                    113123, 113321, 133121, 313121, 211331, 231131, 213113, 213311, 213131, _
                    311123, 311321, 331121, 312113, 312311, 332111, 314111, 221411, 431111, _
                    111224, 111422, 121124, 121421, 141122, 141221, 112214, 112412, 122114, _
                    122411, 142112, 142211, 241211, 221114, 413111, 241112, 134111, 111242, _
                    121142, 121241, 114212, 124112, 124211, 411212, 421112, 421211, 212141, _
                    214121, 412121, 111143, 111341, 131141, 114113, 114311, 411113, 411311, _
                    113141, 114131, 311141, 411131)
    mynumber = Array(" ", "!", """", "#", "$", "%", "&", "'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1" _
                    , "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", _
                    "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", _
                    "W", "X", "Y", "Z", "[", "\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", _
                    "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", _
                    "}", "~", "DEL", "FNC 3", "FNC 2", "SHIFT", "CODE C", "FNC 4", "CODE A", "FNC 1")
    Set sh = ActiveSheet
    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 = 8
    Cells.Font.Size = 6
    sh.Activate
    For Each c In Selection
        mycode = "9211214"
        For i = 1 To Len(c)
            mycode = mycode & textcode(IndexNumber(mynumber, StrConv(Mid(c, i, 1), vbNarrow)))
        Next
        t = 104
        For a = 1 To Len(c)
            t = t + a * IndexNumber(mynumber, StrConv(Mid(c, a, 1), vbNarrow))
        Next
        mycode = mycode & textcode(t Mod 103)
        mycode = mycode & "23311129"
        shbar.Activate
        m = 1
        For q = 1 To Len(mycode)
            Select Case q Mod 2
                Case 1
                    For y = 1 To CInt(Mid(mycode, q, 1))
                    m = m + 1
                    Next
                Case 0
                For y = 1 To CInt(Mid(mycode, q, 1))
                    Cells(2, m).Interior.Color = 0
                    m = m + 1
                Next
            End Select
        Next
        With Range(Cells(3, 1), Cells(3, m))
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .ShrinkToFit = True
        End With
        Range("A3").NumberFormatLocal = "@"
        Range("A3").Value = c.Value
        shbar.Range(Cells(2, 1), Cells(3, m)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        sh.Activate
        c.Offset(0, 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
        shbar.Cells.UnMerge
    Next c
    Application.DisplayAlerts = False
        shbar.Delete
    Application.DisplayAlerts = True
End Sub

今貼り付けたプログラムを実行する
バーコードを作りたいデータの入ったセルを選択し、「開発タブ」の「マクロ」を選択します。
(選択したセル分のみを処理します)
開発タブが表示されて無い場合は開発タブを表示する方法を参考にしてください。

「CODE128_B」を選択し「実行」をクリックしてください

ここまでの手順をこなすと、CODE128のコードセットBのバーコードができると思います。

一応何とかCODE128のコードセットBを作れるようにできたと思いますが、私はプログラムに関しては素人です。
当ブログの記事を用いることによって被った損害・損失に対しては一切の責任を負いかねますのであらかじめご了承下さい。

ちなみに文字を表示させたくない場合は下記のコードを使用してください
Function IndexNumber(Target1, Target2)
Dim i As Integer
For i = 0 To UBound(Target1)
If Target1(i) = Target2 Then Exit For
Next
IndexNumber = i
End Function
Sub CODE128_B_数字なし()
Application.ScreenUpdating = False
Dim textcode, mynumber As Variant
Dim mycode As String
Dim c As Range
Dim i, a, q, x, y, m As Integer
Dim t As Double
Dim shbar, sh As Worksheet
textcode = Array(212222, 222122, 222221, 121223, 121322, 131222, 122213, 122312, 132212, _
221213, 221312, 231212, 112232, 122132, 122231, 113222, 123122, 123221, _
223211, 221132, 221231, 213212, 223112, 312131, 311222, 321122, 321221, _
312212, 322112, 322211, 212123, 212321, 232121, 111323, 131123, 131321, _
112313, 132113, 132311, 211313, 231113, 231311, 112133, 112331, 132131, _
113123, 113321, 133121, 313121, 211331, 231131, 213113, 213311, 213131, _
311123, 311321, 331121, 312113, 312311, 332111, 314111, 221411, 431111, _
111224, 111422, 121124, 121421, 141122, 141221, 112214, 112412, 122114, _
122411, 142112, 142211, 241211, 221114, 413111, 241112, 134111, 111242, _
121142, 121241, 114212, 124112, 124211, 411212, 421112, 421211, 212141, _
214121, 412121, 111143, 111341, 131141, 114113, 114311, 411113, 411311, _
113141, 114131, 311141, 411131)
mynumber = Array(" ", "!", """", "#", "$", "%", "&", "'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1" _
, "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", _
"D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", _
"W", "X", "Y", "Z", "[", "\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", _
"j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", _
"}", "~", "DEL", "FNC 3", "FNC 2", "SHIFT", "CODE C", "FNC 4", "CODE A", "FNC 1")
Set sh = ActiveSheet
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 = 8
Cells.Font.Size = 6
sh.Activate
For Each c In Selection
mycode = "9211214"
For i = 1 To Len(c)
mycode = mycode & textcode(IndexNumber(mynumber, StrConv(Mid(c, i, 1), vbNarrow)))
Next
t = 104
For a = 1 To Len(c)
t = t + a * IndexNumber(mynumber, StrConv(Mid(c, a, 1), vbNarrow))
Next
mycode = mycode & textcode(t Mod 103)
mycode = mycode & "23311129"
shbar.Activate
m = 1
For q = 1 To Len(mycode)
Select Case q Mod 2
Case 1
For y = 1 To CInt(Mid(mycode, q, 1))
m = m + 1
Next
Case 0
For y = 1 To CInt(Mid(mycode, q, 1))
Cells(2, m).Interior.Color = 0
m = m + 1
Next
End Select
Next
shbar.Range(Cells(2, 1), Cells(2, m)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
sh.Activate
c.Offset(0, 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
shbar.Cells.UnMerge
Next c
Application.DisplayAlerts = False
shbar.Delete
Application.DisplayAlerts = True
End Sub
シェア頂けると嬉しいです!よろしくお願いします!
URLをコピーする
URLをコピーしました!
  • URLをコピーしました!

コメント

コメント一覧 (13件)

  • ありがとうございました。非常に重宝しております!!
    CODE128は部署内や小規模の会社等では、汎用性のある便利な運用コードであると思われます。
    これをAccessやFreeソフトを併用せずにエクセルのVBAのみで作成できるのは非常に有用で素晴らしいです!
    今後も色々とご教示お願いいたします。

  • 初めまして。
    検索して辿り着きました。
    素晴らしい情報をありがとうございます。
    有難く使わせていただきます。
    因みに、バーコード下の文字を表示させないようにすることも可能でしょうか?
    お忙しいとは思いますが、ご回答のほど宜しくお願いします。

      • 管理人様

        早速のご対応ありがとうございます。
        これで使用範囲が広がります。

        変更箇所を確認させて頂きました。
        未熟な私には大変勉強になります。
        —————————————————–
        With Range(Cells(3, 1), Cells(3, m))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ShrinkToFit = True
        End With
        Range(“A3”).NumberFormatLocal = “@”
        Range(“A3”).Value = c.Value
        shbar.Range(Cells(2, 1), Cells(3, m)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        —————————————————–

        感謝。

  • 拝啓、管理人様
    ありがとうございました。
    感謝、感謝です。
    エクセルで色々と調べてましたが、フォント入れても128は、印刷してもスキャンできなくて(^_^;)
    なにぶんにもボランティア(お金掛けられなく)での会員カード作りで
    個人情報をバーコードにと考えました。
    本当に感謝です。

    • コメントありがとうございます
      お役に立てたのなら幸いです

  • 管理人様
    お世話になりました。
    コード128の桁数を増やす事は可能ですか?
    名前をローマ字にすると桁数が多く、先に教えてもらったコード128ですが14桁以上はスキャンできませんでした。
    増やせるならご教授お願いしますm(_ _)m

    • ※管理人注 14桁以上が読み取れないというこのコメントを見ている方へ
      この問題はプリンターの問題でした。
      その他にもバーコードを読み取るスキャナーの性能等の問題が発生するかもしれませんので、ご注意ください。

  • お世話になります。
    桁数が13桁のバーコードを作りたいのですが、バーコード下の数字が1E+12となってしまいます。
    対応は可能でしょうか?

コメントする

目次
閉じる