| |
下記を実行するとエラーが発生します。
セルを3つくらい選択時はエラーが発生しないのですが
10個以上選択し実行すると
rangeクラスのSpecial〜のエラーがでます
原因わかりますでしょうか。。
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
|
|
ak
- 21/3/19(金) 10:49 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
≪
