我需要宏excel代码，它将检查我的字符串是否格式正确

时间：2013-01-29 09:23:55

标签： excel vba excel-vba

这是我的整个代码，我将解释它以及我想要添加的内容。

第一个函数是调用另外两个函数。

第二个功能用于计算JMBG，这是我国公民的唯一编号。第三个是计算PIB，这是公司的注册号。

这两个功能都可以，它们不需要移动或类似的东西。

我们需要改变第一个功能。如您所见，在第一个函数中，我正在检查输入字符串的长度是否正常。如果长度是13个数字，我调用JMBG，如果它是8，我调用PIB函数。那没问题。

但是我必须在第一个函数中检查其他类型的验证。正如我所说，我的Excel单元格包含13个数字或8个数字。我想在第一个函数中制定一些规则来告诉我，如果我的单元格中除了那些8个数字或13之外还有其他任何东西，然后发给我msg，告诉我单元格中有错误，然后其他两个函数就赢了“被称为。如您所见，我需要验证。

示例：单元格A1：1234567891234 ...有13个数字，将调用JMBG                   08058808 ...有8个数字，PIB将被调用              1234567890123aSdf​​~ ...错误因为字段中有小字母和大字母以及其他字符。

作为所有这些的总和，我需要8个号码来呼叫PIB，13个号码可以呼叫JMBG以及除了那个以外发送错误的任何其他信息。

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ProvjeraID(ID As String) As String

If Len(ID) = 13 Then
ProvjeraID = Provjeri_JMBG(ID)
 'Exit Function
ElseIf Len(ID) = 8 Then
 ProvjeraID = ProvjeriPIB(ID)
 'Exit Function
 Else
 ProvjeraID = "Duzina je razlicita od 8 i od 13"
 'Exit Function
End If

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Provjeri_JMBG(JMBG As String) As String
' Funkcija vraca tekst sa opisom ispravnosti JMBG
' Primijeniti na radnom listu uz pomoc komande: =Proveri_JMBG(adresa)

' Inicijalizacija promenljivih koje se koriste prilikom izrade koda
Dim duzina As Integer, zbir As Integer
Dim cifra(1 To 13) As Integer
Dim dan As Integer, mesec As Integer, godina As String

' Inicijalizacija konstanti
Const ERR_dan = "GREŠKA: podatak o datumu neispravan!"
Const ERR_mesec = "GREŠKA: podatak o mesecu neispravan!"
Const ERR_godina = "GREŠKA: podatak o godini neispravan!"
Const ERR_duzina = "GREŠKA: dužina razlicita od 13!"
Const ERR_kont = "GREŠKA: neispravan kontrolni broj!"
Const OK_JMBG = "JMBG je ispravan"

' Preuzimanje ulaznih vrednosti sa kojima ce se vrsiti operacije
duzina = Len(JMBG)
dan = Int(Left(JMBG, 2))
mesec = Int(Mid$(JMBG, 3, 2))
godina = Mid$(JMBG, 5, 3)

' Provjera dužine JMBG
If (duzina <> 13) Then
  Provjeri_JMBG = "GREŠKA: dužina razlicita od 13!"
  Exit Function
End If

' Provjera datuma
If dan < 1 Then
  Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
  Exit Function
End If

' Provjera mjeseca i dana u mjesecu
Select Case mesec
  Case 1, 3, 5, 7, 8, 10, 12
    If dan > 31 Then
      Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
      Exit Function
    End If
  Case 4, 6, 9, 11
    If dan > 30 Then
      Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
      Exit Function
    End If
  Case 2
    If ((godina Mod 4 = 0) And dan > 29) Or _
       ((godina Mod 4 <> 0) And dan > 28) Then
      Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
      Exit Function
    End If
  Case Else
    Provjeri_JMBG = "GREŠKA: podatak o mesecu neispravan!"
    Exit Function
End Select

' Provjera godine: ispravne su od 1899 do tekuce godine
If (godina > Right(Str(Year(Now)), 3)) And (godina < "899") Then
  Provjeri_JMBG = "GREŠKA: podatak o godini neispravan!"
  Exit Function
End If

' Provjera kontrolnog broja
For i = 1 To 13
  cifra(i) = Int(Mid$(JMBG, i, 1))
Next i

zbir = cifra(13) + cifra(1) * 7 + cifra(2) * 6
zbir = zbir + cifra(3) * 5 + cifra(4) * 4
zbir = zbir + cifra(5) * 3 + cifra(6) * 2
zbir = zbir + cifra(7) * 7 + cifra(8) * 6
zbir = zbir + cifra(9) * 5 + cifra(10) * 4
zbir = zbir + cifra(11) * 3 + cifra(12) * 2

If (zbir Mod 11) <> 0 Then
  Provjeri_JMBG = "GREŠKA: neispravan kontrolni broj!"
Else
  Provjeri_JMBG = "JMBG je ispravan"
End If

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function ProvjeriPIB(PIB As String)
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
zadnji = Right(PIB, 1)
PIB = Left(PIB, 8)
If Len(PIB) <> 8 Then
   ProvjeriPIB = "PIB je OK"
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 <> zadnji Then
        ProvjeriPIB = "PIB je OK"
       Else
        ProvjeriPIB = "PIB nije OK"
       End If
       'return(pib || to_char(c0));

End If
End Function

4 个答案:

答案 0 :(得分：2)

此解决方案基于Scripting库中的regex。我使用了3个对象，但代码肯定是 trimmed ，只使用一个对象来检查所需的所有三个条件。由于您需要有关正在插入的文本的信息，因此我只使用了3种不同的regex规则。

Option Explicit

Sub TextNature()
Dim str  As String
Dim strMsg As String
Dim objRegEx1 As Object, objRegEx2 As Object
Dim objRegEx3 As Object

str = Sheets(1).Range("A2").Value

'--check length
If Len(str) <> 13 Then
   Exit Sub
   strMsg = "Too lengthy...limit should be 13"
End If

Set objRegEx1 = CreateObject("VBScript.RegExp")
Set objRegEx2 = CreateObject("VBScript.RegExp")
Set objRegEx3 = CreateObject("VBScript.RegExp")
objRegEx1.IgnoreCase = False
objRegEx1.Global = True
objRegEx2.IgnoreCase = False
objRegEx2.Global = True
objRegEx3.IgnoreCase = False
objRegEx3.Global = True


objRegEx1.Pattern = "^\d+$" '-- only numbers
objRegEx2.Pattern = "^[a-zA-Z]+$" '-- only lower upper letters
objRegEx3.Pattern = "^[a-zA-Z\d]+$" '-- numbers and lower upper letters

If objRegEx1.Test(str) Then
    strMsg = "Contain only numbers"
ElseIf objRegEx2.Test(str) Then
    strMsg = "Contain only lower upper letters"
ElseIf objRegEx3.Test(str) Then
    strMsg = "Contain numbers and lower upper letters"
Else
     strMsg = "not satisfying"
End If

End Sub

结果：使用sub作为函数：

enter image description here

OP请求函数，长度限制为8：

Option Explicit

Function TextNature(ByRef rng As Range) As String
Dim str  As String, strMsg As String
Dim objRegEx1 As Object, objRegEx2 As Object, objRegEx3 As Object

str = rng.Value
If Len(str) <> 8 Then
    TextNature = "Limit is not correct. It should be 8."
    Exit Function
End If

Set objRegEx1 = CreateObject("VBScript.RegExp")
Set objRegEx2 = CreateObject("VBScript.RegExp")
Set objRegEx3 = CreateObject("VBScript.RegExp")
objRegEx1.IgnoreCase = False
objRegEx1.Global = True
objRegEx2.IgnoreCase = False
objRegEx2.Global = True
objRegEx3.IgnoreCase = False
objRegEx3.Global = True


objRegEx1.Pattern = "^\d+$" '-- only numbers
objRegEx2.Pattern = "^[a-zA-Z]+$" '-- only lower/upper letters
objRegEx3.Pattern = "^[a-zA-Z\d]+$" '-- numbers and lower/upper letters

If objRegEx1.Test(str) Then
    strMsg = "Contain only numbers"
ElseIf objRegEx2.Test(str) Then
    strMsg = "Contain only lower upper letters"
ElseIf objRegEx3.Test(str) Then
    strMsg = "Contain numbers and lower upper letters"
Else
     strMsg = "Not Satisfying"
End If

TextNature = strMsg
End Function

答案 1 :(得分：0)

这样的东西应该有帮助 - 您可以在select语句中定义条件。它是一个UDF，因此将代码放入模块并将=checkcell(A1)输入到单元格中。

Public Function CheckCell(ByVal CheckRange As Range) As String
Dim strChr As String, rngCheck As Range
Dim i As Integer, NPC As Integer, UC As Integer, LC As Integer, OT As Integer
Set rngCheck = Range("A1")
For i = 1 To rngCheck.Characters.Count
    strChr = rngCheck.Characters(i, 1).Text
    Select Case Asc(strChr)
        Case 0 To 31
            NPC = NPC + 1
        Case 96 To 122
            LC = LC + 1
        Case 65 To 90
            UC = UC + 1
        Case Else
            OT = OT + 1
    End Select
Next
CheckCell = "NPC: " & NPC & " UC: " & UC & " LC: " & LC & " Others: " & OT
End Function

答案 2 :(得分：0)

如果基于公式的解决方案没问题 - 请使用此 ARRAY 公式（假设检查字符串位于A1）：

=IF(OR(NOT(ISERROR(SEARCH(ROW($1:$10)-1,A1)))),"Has digits","No digits")

并按 CTRL + SHIFT + ENTER 而不是通常的 ENTER - 这将定义一个ARRAY公式，会在其周围生成{}括号（但不要手动输入！）。

字符串长度和任何其他字符无关紧要。希望有帮助）

答案 3 :(得分：0)

使用以下内容替换您的第一个函数，并使用=ProvjeraID2(A1)在单元格中调用它来评估单元格 A1 的内容：

Function ProvjeraID2(oRng As Range) As String
    Dim sRet As String

    If Not oRng Is Nothing Then
        If IsNumeric(oRng.Value) Then
            If Len(oRng.Value) = 13 Then
                sRet = Provjeri_JMBG(CStr(oRng.Value))
            ElseIf Len(oRng.Value) = 8 Then
                sRet = ProvjeriPIB(CStr(oRng.Value))
            Else
                sRet = "Numeric but wrong length (" & Len(oRng.Value) & ")"
            End If
        Else
            sRet = "Not a number"
        End If
    End If

    ProvjeraID2 = sRet
End Function
相关问题
最新问题