分享一段代码主要用到正则表达式来判断字符串

sinoxo

1. 
   
2. 
   
3. 'Test the string
   
4. Function regex_Test(ByVal strTest As String, ByVal strRegExp As String)
   
5. '╋────────────────────────╋
   
6. ' 本程序使用正则式对输入字符串进行匹配，若匹配
   
7. ' 成功，则返回TRUE，否则返回FALSE。
   
8. ' 字符串和正则表达式需要外部输入。
   
9. '╋────────────────────────╋
   
10. ' Author: sinoxo
    
11. ' Date: 2015年1月8日10:27:36
    
12. ' Version: V 1.0
    
13. '╋────────────────────────╋
    
14. On Error Resume Next
    
15. Dim regex As Object
    
16. Set regex = CreateObject("VBScript.RegExp")
    
17. With regex
    
18. .Global = True
    
19. .Pattern = strRegExp
    
20. regex_Test = .test(strTest)
    
21. End With
    
22. End Function

复制代码

Sub CableListCheck()
'╋────────────────────────╋
' 本程序检查清册内容的正确性和完备性。
' 本程序只能检查以行为单位的清册内容，对于供应商
' 的清册文件，可能需要进行前期审查才能使用本程序
' 对错误的数据标记为蓝色，缺少字段将弹出消息框。
' 检查之前会将当前文件另存为结果文件。
'╋────────────────────────╋
' Author: sinoxo
' Date: 2015年1月8日10:32:22
' Version: V 1.0
'╋────────────────────────╋
Dim ListLastRow As Long
Dim r As Long
Dim c As Long
Dim str_Code As String
Dim sourceSheet As Worksheet
Dim checkSheet As Worksheet
Dim StrMsg As String
Dim tmpArr
Dim RegCable_Number As String
Dim RegRoom As String
Dim RegUPC As String
Dim RegVoltage_level As String
Dim RegColor As String
Dim RegRevision As String
Dim RegStatus As String
Dim RegDivison As String
Dim RegEquipmentSpc As String
Dim RegEquipmentAdd As String
Dim RegSymbol As String
Dim RegEquipment As String
Dim intColorIndex As Integer
Dim intPoint As Integer: intPoint = 0

'read title
ColArray = TitleRead
'check columns of the list
'if lost some key informations then show a tip and exit macro
If ColArray(0) = 0 Then StrMsg = Chr(13) & Chr(9) & "- Cable_Number"
If ColArray(1) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Room_from"
If ColArray(2) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Source"
If ColArray(3) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Place_from"
If ColArray(4) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Room_to"
If ColArray(5) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Destination"
If ColArray(6) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Place_to"
If ColArray(7) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Cable_key"
'If ColArray(8) = 0 Then StrMsg _
= StrMsg &Chr(13) & Chr(9) & "- Origin_key" 'not key information
If ColArray(9) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Voltage_level"
If ColArray(10) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Divison"
'If ColArray(11) = 0 Then StrMsg _
= StrMsg &Chr(13) & Chr(9) & "- Safety_Class"'not key information
'If ColArray(12) = 0 Then StrMsg _
= StrMsg &Chr(13) & Chr(9) & "- Qualification"'not key information
If ColArray(13) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Color"
'If ColArray(14) = 0 Then StrMsg _
= StrMsg &Chr(13) & Chr(9) & "- Length"'not key information
If ColArray(15) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Revision"
If ColArray(16) = 0 Then StrMsg = StrMsg & Chr(13) & Chr(9) & "- Status"
If StrMsg <> "" Then
MsgBox "Lose key information as below:" _
& Chr(13) & StrMsg & Chr(13) & Chr(13) _
& "Please check the source file and try again.", , "Cable List Check "
'Exit Sub
End If
ActiveWorkbook.SaveAs _
Left(ActiveWorkbook.FullName, InStr(Len(ActiveWorkbook.FullName) - 5, _
ActiveWorkbook.FullName, ".") - 1) _
& "_CLC_" & Format(Date$, "mmdd") _
& "_" & Format(Time$, "hhmmss") _
& "xlsx", 51

Set sourceSheet = ActiveSheet

sourceSheet.Activate
ListLastRow = Application.Max(sourceSheet.Range("b65535").End(xlUp).Row, _
sourceSheet.Range("c65535").End(xlUp).Row, _
sourceSheet.Range("d65535").End(xlUp).Row)
tmpArr = sourceSheet.UsedRange
RegCable_Number = "^[0-9]{1}[A-Z]{3}(A|B|C|D|E|F|G|I|M|P|S|T){1}[0-9]{4}$"
RegRoom = "^[0-9]{1}(((D|DA|DB|E|K|L|N|NA|NB|NC|ND|NE|NF|R|W)[0-9]{3})|([M]{1}[A-Z]{1}([0-9]{1}[A-Z]{1}[0-9]{1}|[0-9]{3})))$"
RegUPC = "^[6]{1}[0-9]{4}$"
RegVoltage_level = "^(A|B|C|D|E|F|G|I|M|P|S|T)$"
RegColor = "^(BL|BR|CO|CO|GR|GR|OR|OR|PU|RE|TU|YE)$"
RegStatus = "^(C|M|D)$"
RegRevision = "^[A-Z]{1}$"
RegDivison = "^(Ⅰ|ⅠP|Ⅱ|ⅡP|Ⅲ|ⅢP|Ⅳ|ⅣP|A|B|G1|G2|G3|G4|IIIP|IIP|IP|IVP|P1|P2)$"
RegEquipmentSpc = "(PO|ZV|[0-9]{3}V|GF|MO|RS){1}$"
RegEquipmentAdd = "(PO-F|ZV-F|V-F|GF-F|MO-F|RS-F){1}"
RegSymbol = "(#|\*|&|%|\?|\s|\(|\))"
RegEquipment = "^[0-9]{1}(([A-Z]{3}[0-9]{3})|((ZZZL)[0-9]{3}))"
intColorIndex = 33

For r = ColArray(17) + 1 To ListLastRow
'check cable number
If Not regex_Test(tmpArr(r, ColArray(0)), RegCable_Number) _
Then sourceSheet.Cells(r, ColArray(0)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
'check room code
If Not regex_Test(tmpArr(r, ColArray(1)), RegRoom) _
Then sourceSheet.Cells(r, ColArray(1)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
If Not regex_Test(tmpArr(r, ColArray(4)), RegRoom) _
Then sourceSheet.Cells(r, ColArray(4)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
'chek upc
If ColArray(7) > 0 Then
If Not regex_Test(tmpArr(r, ColArray(7)), RegUPC) _
Then sourceSheet.Cells(r, ColArray(7)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
End If
'chek voltage level
If ColArray(9) > 0 Then
If Not regex_Test(tmpArr(r, ColArray(9)), RegVoltage_level) _
Then sourceSheet.Cells(r, ColArray(9)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
End If
'chek color
If Not regex_Test(tmpArr(r, ColArray(13)), RegColor) _
Then sourceSheet.Cells(r, ColArray(13)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
'chek status
If ColArray(16) > 0 Then
If Not regex_Test(tmpArr(r, ColArray(16)), RegStatus) _
Then sourceSheet.Cells(r, ColArray(16)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
End If
'chek division
If Not regex_Test(tmpArr(r, ColArray(10)), RegDivison) _
Then sourceSheet.Cells(r, ColArray(10)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
'chek revision
If Not regex_Test(tmpArr(r, ColArray(15)), RegRevision) _
Then sourceSheet.Cells(r, ColArray(15)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
'chek equipment
If regex_Test(tmpArr(r, ColArray(2)), RegEquipmentSpc) _
And regex_Test(tmpArr(r, ColArray(2)), RegEquipment) _
And Not regex_Test(tmpArr(r, ColArray(2)), RegEquipmentAdd) _
Then sourceSheet.Cells(r, ColArray(2)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
If regex_Test(tmpArr(r, ColArray(5)), RegEquipmentSpc) _
And regex_Test(tmpArr(r, ColArray(5)), RegEquipment) _
And Not regex_Test(tmpArr(r, ColArray(5)), RegEquipmentAdd) _
Then sourceSheet.Cells(r, ColArray(5)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
For c = 0 To 16
'check
If ColArray(c) <> 0 Then
If regex_Test(tmpArr(r, ColArray(c)), RegSymbol) _
Then sourceSheet.Cells(r, ColArray(c)).Interior.ColorIndex _
= intColorIndex: intPoint = 1
End If
Next
Next
If intPoint = 1 Then
MsgBox "Check fails, please see blue mark area.", _
vbInformation + vbOKOnly, "Cable List Check "
Call writeLog("CableListCheck", ListLastRow & " fails")
Else
MsgBox "Bingo! The file looks good.", _
vbOKOnly, "Cable List Check "
Call writeLog("CableListCheck", ListLastRow & " Bingo")
End If

End Sub

Curry_Chen

好贴！！收藏之~~