ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2027|回复: 1

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-1-8 11:43 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:文本处理和正则
本帖最后由 sinoxo 于 2015-1-8 11:50 编辑


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


TA的精华主题

TA的得分主题

发表于 2015-1-17 22:14 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 16:56 , Processed in 0.044895 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表