この機能は、JMBG（固有の市民権番号）とPIB番号（企業用）をチェックします
それらが正しくない場合、関数はエラー メッセージを返します。
私の関数も新しいワークシートを作成して、すべての間違った JMBG または PIB 番号をエラー メッセージとともに配置したいと考えています。
次に例を示します。
Worksheet1 には、セル A1 に例が含まれています。
0805988212987
CheckID(A1) を呼び出すと ---> JMBG が正しいという結果が返されます
1234
それは私にエラーメッセージを返します
workhseet2ここで、関数がすぐに新しいワークシート ( ) を
作成し、そこに12345エラー メッセージが表示されるようにしたいと考えています。
つまり、worksheet1数字がたくさんある場所があり、それらすべてをチェックするということです。
エラーメッセージのあるすべての数字を新しいワークシートに移動し、そのメッセージを赤または他の色で色付けしたいと思います。
下は私の現在の機能です。最初は他の 2 をコールバックするメイン関数です。
Excel シートの例:
0805988212987 JMBG is correct
20538350 PIB is correct
abcdef ERROR: Function can not check JMBG nor PIB ...
ABCDEF ERROR: Cell contains only UPPER letters. Numeric input ...
AVGsgh ERROR: There is error because cell contains only LOWER and UPPER...
Marko Dragovic ERROR: Wrong input data. Cell is empty. Must be numeric and 8 or 13
12345 ERROR: Excel cell limit is not correct. It should be 8 or 13, and numeric.
ERROR: Wrong input data. Cell is empty. Must be numeric and 8 or 13 length
JMBG ERROR: Cell contains only UPPER letters. Numeric input of cell not achieved
0 ERROR: Excel cell limit is not correct. It should be 8 or 13, and numeric.
すべてのエラーが自動的に新しいシートに移動され、赤く色付けされるようにします。
Function CheckID(ByRef rng As Range) As String
Dim str As String, strMsg As String
Dim objRegEx1 As Object, objRegEx2 As Object, objRegEx3 As Object
Dim sret As String
str = rng.Value
Set objRegEx1 = CreateObject("VBScript.RegExp")
Set objRegEx2 = CreateObject("VBScript.RegExp")
Set objRegEx3 = CreateObject("VBScript.RegExp")
Set objRegEx4 = CreateObject("VBScript.RegExp")
Set objRegEx5 = CreateObject("VBScript.RegExp")
Set objRegEx6 = CreateObject("VBScript.RegExp")
Set objRegEx7 = CreateObject("VBScript.RegExp")
objRegEx1.IgnoreCase = False
objRegEx1.Global = True
objRegEx2.IgnoreCase = False
objRegEx2.Global = True
objRegEx3.IgnoreCase = False
objRegEx3.Global = True
objRegEx4.IgnoreCase = False
objRegEx4.Global = True
objRegEx5.IgnoreCase = False
objRegEx5.Global = True
objRegEx6.IgnoreCase = False
objRegEx6.Global = True
objRegEx7.IgnoreCase = False
objRegEx7.Global = True
objRegEx1.Pattern = "^\d+$" '-- only numbers
objRegEx2.Pattern = "^[a-z]+$" '-- only lower letters
objRegEx3.Pattern = "^[A-Z]+$" '-- only upper letters
objRegEx4.Pattern = "^[a-zA-Z]+$" '-- only lower/upper letters
objRegEx5.Pattern = "^[a-z\d]+$" '-- numbers and lower leters
objRegEx6.Pattern = "^[A-Z\d]+$" '-- numbers and upper letters
objRegEx7.Pattern = "^[a-zA-Z\d]+$" '-- numbers and lower/upper letters
If objRegEx1.Test(str) Then
If (Len(str) <> 13) And (Len(str) <> 8) Then
strMsg = "ERROR: Cell numeric limit is not correct. It should be 8 or 13."
ElseIf Len(str) = 13 Then
strMsg = Check_JMBG(CStr(str))
ElseIf Len(str) = 8 Then
strMsg = Check_PIB(CStr(str))
End If
ElseIf objRegEx2.Test(str) Then
strMsg = "ERROR: Function can not check JMBG nor PIB because cell contains only LOWER letters. Numeric input of cell not achieved"
ElseIf objRegEx3.Test(str) Then
strMsg = "ERROR: Cell contains only UPPER letters. Numeric input of cell not achieved and thus nor JMBG nor PIB is going to be checked"
ElseIf objRegEx4.Test(str) Then
strMsg = "ERROR: Cell contains only LOWER and UPPER letters. Numeric input of cell not achieved"
ElseIf objRegEx5.Test(str) Then
strMsg = "ERROR: Cell contains NUMBERS and LOWER letters. Function can't check JMBG or PIB because they are not entered correct. Numeric input of cell not achieved"
ElseIf objRegEx6.Test(str) Then
strMsg = "ERROR: There is no JMBG or PIB in the valid form in the cell. Cell contains NUMBERS and UPPER letters. Numeric input of cell not achieved"
ElseIf objRegEx7.Test(str) Then
strMsg = "ERROR: Because cell contains NUMBERS, LOWER and UPPER letters, numeric input of cell is not achieved. Enter correct data"
ElseIf IsEmpty(cell) Then
strMsg = "ERROR: Cell is empty"
Else
strMsg = "ERROR: Cell not satisfying input arguments. There are special characters in the cell or it is empty. Numeric input of cell not achieved"
End If
CheckID = strMsg
End Function
Public Function Check_PIB(PIB As String)
'Function for checking PIB
'Initialization of all values inside PIB, 8 numbers, 1 control number
Dim c0 As Integer
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim c4 As Integer
Dim c5 As Integer
Dim c6 As Integer
Dim c7 As Integer
Dim c8 As Integer
Dim zadnji As String
last = Right(PIB, 1)
PIB = Left(PIB, 8)
If Len(PIB) <> 8 Then
Check_PIB = "PIB is correct"
Else
c8 = (CInt(Mid(PIB, 1, 1)) + 10) Mod 10
If c8 = 0 Then
c8 = 10
End If
c8 = (c8 * 2) Mod 11
c7 = (CInt(Mid(PIB, 2, 1)) + c8) Mod 10
If c7 = 0 Then
c7 = 10
End If
c7 = (c7 * 2) Mod 11
c6 = (CInt(Mid(PIB, 3, 1)) + c7) Mod 10
If c6 = 0 Then
c6 = 10
End If
c6 = (c6 * 2) Mod 11
c5 = (CInt(Mid(PIB, 4, 1)) + c6) Mod 10
If c5 = 0 Then
c5 = 10
End If
c5 = (c5 * 2) Mod 11
c4 = (CInt(Mid(PIB, 5, 1)) + c5) Mod 10
If c4 = 0 Then
c4 = 10
End If
c4 = (c4 * 2) Mod 11
c3 = (CInt(Mid(PIB, 6, 1)) + c4) Mod 10
If c3 = 0 Then
c3 = 10
End If
c3 = (c3 * 2) Mod 11
c2 = (CInt(Mid(PIB, 7, 1)) + c3) Mod 10
If c2 = 0 Then
c2 = 10
End If
c2 = (c2 * 2) Mod 11
c1 = (CInt(Mid(PIB, 8, 1)) + c2) Mod 10
If c1 = 0 Then
c1 = 10
End If
c1 = (c1 * 2) Mod 11
c0 = (11 - c1) Mod 10
If c0 <> last Then
Check_PIB = "PIB is correct"
Else
Check_PIB = "Error: Wrong PIB. Not valid"
End If
End If
End Function
Function Check_JMBG(JMBG As String) As String
If (Len(JMBG) <> 13) Then
Check_JMBG = "ERR: Length of JMBG is not 13!"
ElseIf Not IsNumeric(JMBG) Then
Check_JMBG = "ERR: JMBG contains non-numerical characters"
ElseIf Not fctBlnCheckDate(JMBG) Then
Check_JMBG = "ERR: Wrong JMBG date entered!"
ElseIf fctBlnCheckSum(JMBG) Then
Check_JMBG = "ERR: Wrong JMBG checksum!"
Else
Check_JMBG = "JMBG is correct"
End If
End Function
Private Function fctBlnCheckDate(JMBG As String) As Boolean
Dim intDay As Integer, intMonth As Integer, intYear As Integer
Dim datCheck As Date
intDay = Int(Left(JMBG, 2))
intMonth = Int(Mid$(JMBG, 3, 2))
intYear = Int(Mid$(JMBG, 5, 3)) + 1000
datCheck = DateSerial(intYear, intMonth, intDay)
fctBlnCheckDate = _
(Year(datCheck) = intYear) And _
(Month(datCheck) = intMonth) And _
(Day(datCheck) = intDay)
End Function
Private Function fctBlnCheckSum(JMBG As String) As Boolean
Dim intCheckSum As Integer, i As Integer
For i = 1 To 13
intCheckSum = intCheckSum + Int(Mid$(JMBG, i, 1))
Next i
End Function