以前作成したバーコード作成用VBAコードの修正と改良
以前にこちらの記事でバーコードを作成するExcelVBAコードを紹介しましたが、その時は下記の問題点・課題がありました。
今回はこれらの課題を修正した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
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列に画像として貼り付けることができるようになりました。
コメント