ExcelVBAの機能でバーコードを作成する2

スポンサーリンク

以前作成したバーコード作成用VBAコードの修正と改良

以前にこちらの記事でバーコードを作成するExcelVBAコードを紹介しましたが、その時は下記の問題点・課題がありました。

  • ①8桁JANコードを作成できない
  • ②バーコードがセルの背景色として作られているので使い勝手が良くないなど
  • 今回はこれらの課題を修正したVBAコードを紹介します。

    8桁JANのバーコード作成について

    13桁JANコードと異なり、8桁コードは先頭の付加文字はありません。
    単純に左4桁、右4桁分の数字を表現するだけで作成可能です。

    バーコードの開始位置・真ん中・終了位置には専用のコード「101」・「01010」・「101」が含まれます。
    作り方としては「101」・「左4桁分のコード」・「01010」・「右4桁分のコード」・「101」で並べればOKです。

    13桁JANコードの作成手順についてはこちらの記事を参考にしてください。

    スポンサーリンク

    ExcelVBAでバーコードを作成するコード(改良)

    Sub バーコード作成()

    Dim パリティ
    Dim 左コード
    Dim 右コード
    Dim コード
    Dim i, k
    Dim Shp

    ’ガイド線を消す(消さないとバーコード読めない)
    ActiveWindow.DisplayGridlines = False

    ’L~DD列の色を消して幅をそろえる
    Range(Cells(1, 12), Cells(Rows.Count, 108)).Interior.ColorIndex = xlNone
    Range(Columns(12), Columns(108)).ColumnWidth = 0.13

    ’既存の画像JANコードを削除
    Do Until ActiveSheet.Shapes.Count = 0
    ActiveSheet.Shapes.Range(1).Delete
    Loop

    ’JANコードが記載されているところは継続処理
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    If Len(Cells(i, 1)) = 13 Then

    ’最初の1文字目からパリティを算出
    Select Case Left(Cells(i, 1), 1)
    Case “0”
    パリティ = Array(“奇数”, “奇数”, “奇数”, “奇数”, “奇数”, “奇数”)
    Case “1”
    パリティ = Array(“奇数”, “奇数”, “偶数”, “奇数”, “偶数”, “偶数”)
    Case “2”
    パリティ = Array(“奇数”, “奇数”, “偶数”, “偶数”, “奇数”, “偶数”)
    Case “3”
    パリティ = Array(“奇数”, “奇数”, “偶数”, “偶数”, “偶数”, “奇数”)
    Case “4”
    パリティ = Array(“奇数”, “偶数”, “奇数”, “奇数”, “偶数”, “偶数”)
    Case “5”
    パリティ = Array(“奇数”, “偶数”, “偶数”, “奇数”, “奇数”, “偶数”)
    Case “6”
    パリティ = Array(“奇数”, “偶数”, “偶数”, “偶数”, “奇数”, “奇数”)
    Case “7”
    パリティ = Array(“奇数”, “偶数”, “奇数”, “偶数”, “奇数”, “偶数”)
    Case “8”
    パリティ = Array(“奇数”, “偶数”, “奇数”, “偶数”, “偶数”, “奇数”)
    Case “9”
    パリティ = Array(“奇数”, “偶数”, “偶数”, “奇数”, “偶数”, “奇数”)
    End Select

    コード = “101” ’左ガードバー
    For x = 2 To 7
    If パリティ(x - 2) = “奇数” Then
    左コード = Array(“0001101”, “0011001”, “0010011”, “0111101”, “0100011”, “0110001”, “0101111”, “0111011”, “0110111”, “0001011”)
    コード = コード & 左コード(Mid(Cells(i, 1), x, 1))
    ElseIf パリティ(x - 2) = “偶数” Then
    左コード = Array(“0100111”, “0110011”, “0011011”, “0100001”, “0011101”, “0111001”, “0000101”, “0010001”, “0001001”, “0010111”)
    コード = コード & 左コード(Mid(Cells(i, 1), x, 1))
    End If
    Next x
    コード = コード & “01010” ’センターバー

    For x = 8 To 13
    右コード = Array(“1110010”, “1100110”, “1101100”, “1000010”, “1011100”, “1001110”, “1010000”, “1000100”, “1001000”, “1110100”)
    コード = コード & 右コード(Mid(Cells(i, 1), x, 1))
    Next x

    コード = コード & “101” ’右ガードバー

    For x = 13 To 107 ’変換したコードで色を塗り分ける
    If Mid(コード, x - 12, 1) = “1” Then
    Cells(i, x).Interior.Color = RGB(0, 0, 0)
    ElseIf Mid(コード, x - 12, 1) = “0” Then
    Cells(i, x).Interior.Color = RGB(255, 255, 255)
    End If
    Next x

    ’セルに色付けして作成したバーコードを画像としてコピーしてB列に貼り付け
    Range(Cells(i, 12), Cells(i, 108)).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Cells(i, 2).PasteSpecial
    Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    ’位置とサイズを適当に合わせる
    Shp.LockAspectRatio = msoFalse
    Shp.Width = Columns(2).Width * 3 / 4
    Shp.Height = Rows(i).Height * 1 / 2
    Shp.Top = Shp.Top + Rows(i).Height * 1 / 4
    Shp.Left = Shp.Left + Columns(2).Width * 1 / 8

    ’初期化
    Erase パリティ
    Erase 右コード
    Erase 左コード
    コード = “”
    Set Shp = Nothing

    ElseIf Len(Cells(i, 1)) = 8 Then

    コード = “101” ’左ガードバー
    For x = 1 To 4
    左コード = Array(“0001101”, “0011001”, “0010011”, “0111101”, “0100011”, “0110001”, “0101111”, “0111011”, “0110111”, “0001011”)
    コード = コード & 左コード(Mid(Cells(i, 1), x, 1))
    Next x
    コード = コード & “01010” ’センターバー

    For x = 5 To 8
    右コード = Array(“1110010”, “1100110”, “1101100”, “1000010”, “1011100”, “1001110”, “1010000”, “1000100”, “1001000”, “1110100”)
    コード = コード & 右コード(Mid(Cells(i, 1), x, 1))
    Next x

    コード = コード & “101” ’右ガードバー

    For x = 30 To 96
    If Mid(コード, x - 29, 1) = “1” Then
    Cells(i, x).Interior.Color = RGB(0, 0, 0)
    ElseIf Mid(コード, x - 29, 1) = “0” Then
    Cells(i, x).Interior.Color = RGB(255, 255, 255)
    End If
    Next x

    ’セルに色付けして作成したバーコードを画像としてコピーしてB列に貼り付け
    Range(Cells(i, 29), Cells(i, 97)).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Cells(i, 2).PasteSpecial
    Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    ’位置とサイズを適当に合わせる
    Shp.LockAspectRatio = msoFalse
    Shp.Width = Columns(2).Width * 3 / 4
    Shp.Height = Rows(i).Height * 1 / 2
    Shp.Top = Shp.Top + Rows(i).Height * 1 / 4
    Shp.Left = Shp.Left + Columns(2).Width * 1 / 8

    ’初期化
    Erase パリティ
    Erase 右コード
    Erase 左コード
    コード = “”

    Set Shp = Nothing

    End If

    Next i

    End Sub

    セル範囲をコピーして画像として貼り付けるコードの説明はこちらの記事をご覧ください。

    これでA列のJANコードをB列に画像として貼り付けることができるようになりました。

    スポンサーリンク

    シェアする

    • このエントリーをはてなブックマークに追加

    フォローする