使用EXCEL UDF在另一个工作表中填充单元格值，颜色

Question

此功能检查JMBG（唯一公民号码）和PIB号码（公司）

如果它们是错误的函数返回错误消息。

我希望我的函数还创建新的工作表，以便将所有错误的JMBG或PIB编号与错误消息放在一起。

以下是一个例子：

Worksheet1包含单元格A1中的示例：

0805988212987

当我打电话给CheckID（A1）---＆gt;它回到我身边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

Answer 1

编辑这对UDF无效。

这是你要找的？

如果要将其记录下来，请在代码中使用logging

Sub logging(ByVal val As String, ByVal msg As String)
Dim logWs As Worksheet
Err.Clear
On Error Resume Next
Set logWs = Worksheets("Error Log")
If Err.Number <> 0 Then
    Set logWs = Worksheets.Add
    logWs.Name = "Error Log"
End If
On Error GoTo 0

With logWs
    Height = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(Height + 1, 1).Value = val
    .Cells(Height + 1, 2).Value = msg
    .Cells(Height + 1, 2).Font.Color = RGB(255, 0, 0) ' RED in color
End With
Set logWs = Nothing

End Sub

Sub testing()
    logging "123", "ERR"
End Sub

修改 作为请求，假设您的所有错误消息都以“ERROR：”

开头

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
    'Modified by: Larry
    'Modified Date: 31-01-2013
    'Take Log in "Error Log" Sheet if it's an error
    If InStr(UCase(strMsg), "ERROR:") > 0 Then
        logging str, strMsg
    End If

    CheckID = strMsg
End Function