ExcelVBA_VBScript实例集锦.pdf
1,统一字符（Pattern、Replace）http:/ 统一字符.xls Sub yyOOBIRD()With CreateObject(VBSCRIPT.REGEXP).Global=True For i=2 To g65536.End(xlUp).Row.Pattern=D 数字模式s1=.Replace(Cells(i,7),).Pattern=u4e00-u9fa5 汉字模式s2=.Replace(Cells(i,7),)Cells(i,9)=s1&.&s2 Next i End With End Sub Sub yy()by:蓝桥Dim Myr%,x%,aa$Dim temp$,getelement1$,getelement2$Myr=g65536.End(xlUp).Row For x=2 To Myr aa=Cells(x,7)For y=1 To Len(aa)temp=Mid(aa,y,1)If temp Like 0-9 Then getelement1=getelement1&temp数字模式If Asc(temp)0 Then getelement2=getelement2&temp汉字模式Next y Cells(x,9)=getelement1&.&getelement2 getelement1=getelement2=Next x End Sub 自定义函数n=1 数字；n=2 中文；n=3 字母Function yy(aa,n)Dim temp$,getelement1$,y&For y=1 To Len(aa)temp=Mid(aa,y,1)Select Case n Case 1 If temp Like 0-9 Then getelement1=getelement1&temp 数字模式Case 2 If Asc(temp)1 Then Exit Sub If Target.Column 5 Then Exit Sub Myr=e65536.End(xlUp).Row Range(E3:E&Myr).Sort Range(E3),1 With CreateObject(VBSCRIPT.REGEXP).Global=True.Pattern=s For i=Myr To 3 Step-1 s1=.Replace(Cells(i,5),)If Cells(i,5)=Or s1=Then Cells(i,5).Delete Shift:=xlUp ElseIf Cells(i,5)=0 Then Application.EnableEvents=False Cells(i,5).Cut Myr=e65536.End(xlUp).Row+1 Cells(Myr,5).Select ActiveSheet.Paste Cells(i,5).Select Selection.Delete Shift:=xlUp Application.EnableEvents=True End If Next End With End Sub 6，去除/*%http:/ 分隔符拆分0411.xls Sub yy()Dim RegEx,Myr&,x&,a,b,bb Set RegEx=CreateObject(VBSCRIPT.REGEXP)RegEx为建立正则表达式RegEx.Global=True 设置全局可用RegEx.Pattern=/|*|%Myr=a65536.End(xlUp).Row For x=2 To Myr a=Cells(x,1)b=RegEx.Replace(a,|)把匹配样式的字符用|替换bb=Split(b,|)Cells(x,2).Resize(1,UBound(bb)+1)=bb Next x Set RegEx=Nothing End Sub 7，搜索(Match 对象)by:Windows脚本技术帮助文件每个 Match 对象提供了被正则表达式搜索找到的字符串的访问、字符串的长度，以及找到匹配的索引位置等。Function RegExpTest(patrn,strng)Dim regEx,Match,Matches 建立变量。Set regEx=New RegExp 建立正则表达式。regEx.Pattern=patrn 设置模式。regEx.IgnoreCase=True 设置是否区分大小写。regEx.Global=True 设置全局可用性。Set Matches=regEx.Execute(strng)执行搜索。For Each Match in Matches 遍历 Matches 集合。RetStr=RetStr&匹配&I&位于 RetStr=RetStr&Match.FirstIndex&.Match Value is RetStr=RetStr&Match.Value&.&vbCRLF Next RegExpTest=RetStr End Function MsgBox(RegExpTest(is.,IS1 is2 IS3 is4)8，取数和取字符串 n=1 时取数；n=2 时取字符串Function ss(rng,n)Dim RegEx,b,bb Set RegEx=CreateObject(VBSCRIPT.REGEXP)RegEx为建立正则表达式RegEx.Global=True 设置全局可用RegEx.Pattern=D b=RegEx.Replace(rng,|)把匹配样式的字符用|替换If n=1 Then ss=Replace(b,|,)数字ElseIf n=2 Then bb=Replace(b,|,)ss=Left(rng,Len(rng)-Len(bb)字符串End If Set RegEx=Nothing End Function 9，取数字表达式 2011-8-31 http:/ Sub Macro1()Dim arr,i&,y arr=Range(a1:a&Range(a65536).End(xlUp).Row)With CreateObject(vbscript.regexp).Global=True.Pattern=(0-9.+*)+0-9.+For i=1 To UBound(arr)y=arr(i,1)If.Execute(y).Count 0 Then arr(i,1)=.Execute(y)(0)Else:arr(i,1)=End If Next End With Range(b1).Resize(UBound(arr),1)=arr End Sub 10，取数字分列 2011-9-19 by:jiminyanyan http:/ Sub Reg()Dim oReg As Object Dim oMatches As Object Dim oMatch As Object Dim i As Integer Set oReg=CreateObject(vbscript.regexp)With oReg.Global=True 设置模式匹配数字.Pattern=d+For i=1 To Range(a65535).End(xlUp).Row 先判断是否匹配成功，成功则继续If.test(Cells(i,1)Then 获得匹配结果的集合Set oMatches=.Execute(Cells(i,1)m=4 For Each oMatch In oMatches Cells(i,m)=oMatch m=m+1 Next End If Next End With End Sub 11，查找电子邮件地址（SubMatches集合）by:Windows脚本技术帮助文件 SubMatches 集合包含了单个的子匹配字符串Function SubMatchTest(inpStr)Dim oRe,oMatch,oMatches Set oRe=New RegExp 查找一个电子邮件地址（不是一个理想的RegExp）oRe.Pattern=(w+)(w+).(w+)得到Matches 集合Set oMatches=oRe.Execute(inpStr)得到Matches 集合中的第一项Set oMatch=oMatches(0)创建结果字符串。Match 对象是完整匹配 retStr=电子邮件地址是：&oMatch&vbNewLine 得到地址的子匹配部分。retStr=retStr&电子邮件别名是：&oMatch.SubMatches(0)dragon retStr=retStr&vbNewLine retStr=retStr&组织是：&oMatch.SubMatches(1)xyzzy SubMatchTest=retStr End Function Sub yy1()MsgBox(SubMatchTest(请写信到。谢谢！)End Sub 12，RGB 函数by:Windows脚本技术帮助文件 返回代表RGB 颜色值的整数Function RevRGB(red,green,blue)RevRGB=CLng(blue+(green*256)+(red*65536)End Function Sub yy2()MsgBox RevRGB(3,4,5)End Sub 13，判断 02-03-0451-222格式by:tonychris http:/ by:tonychris 判断 02-03-0451-222 格式Private Sub Worksheet_Change(ByVal Target As Range)Dim objRegExp As New RegExp objRegExp.Pattern=dd(-dd(-d1,3(-d+)?)?)?$If Not objRegExp.test(Target.Text)Then MsgBox error End If End Sub 14，(=8)只取数字by:hwc2ycy http:/ Sub test()Dim objRegExp As Object Dim strTemp$,a Set objRegExp=CreateObject(VBScript.regExp)strTemp=总装 E 线:75-77 台下线 With objRegExp.Global=True.Pattern=d+If.test(strTemp)Then For Each a In.Execute(strTemp)Debug.Print a.Value Next End If End With Set objRegExp=Nothing End Sub 15，复杂分表（scriptcontrol）2013-7-18 http:/ Sub bxm_lqxs()Dim ojs,i&,Arr,d,a,Myr&,Sht As Worksheet Dim xx$,nm$,k,t,j&,aa Application.ScreenUpdating=False Application.DisplayAlerts=False Set ojs=CreateObject(scriptcontrol):ojs.Language=jscript Set d=CreateObject(Scripting.Dictionary)Sheet1.Activate For Each Sht In Sheets If Sht.Name 总表 And Sht.Name 模板 Then Sht.Delete Next Sht Myr=a65536.End(3).Row Arr=Range(a3:k&Myr)For i=2 To UBound(Arr)a=Split(ojs.eval(&Arr(i,4)&.split(/(大学|学院|系|学校|中心|职业)|小学/),)nm=a(UBound(a)xx=Replace(Arr(i,4),nm,)&Arr(i,8)Arr(i,4)=nm d(xx)=d(xx)&i&,Next k=d.keys:t=d.items For i=0 To UBound(k)t(i)=Left(t(i),Len(t(i)-1)Sheets(模板).Copy after:=Sheets(Sheets.Count)Set Sht=ActiveSheet With Sht.Name=k(i)If InStr(t(i),)Then aa=Split(t(i),)For j=0 To UBound(aa).Cells(j+4,1).Resize(1,UBound(Arr,2)=Application.Index(Arr,aa(j),0)Next Else.Cells(4,1).Resize(1,UBound(Arr,2)=Application.Index(Arr,t(i),0)End If.a4.Resize(UBound(aa)+1,15).Borders.LineStyle=1 End With Next Set ojs=Nothing Application.DisplayAlerts=True Application.ScreenUpdating=True End Sub 16，提取指定的字符串by:zhaogang1980 http:/ Function QS(zfc As String)As String Dim matchs As Object With CreateObject(VBScript.RegExp).Global=True.Pattern=(组装书|汽泡磁胶书|三本套|五本套|硬盒版)Set matchs=.Execute(zfc)If.test(zfc)Then QS=matchs(0).Value End With End Function 17，提取日期的字符串by:gufengaoyue http:/ Sub 按钮 1_Click()Dim filePath$,regEx,brr,Matches,MyStr$With Application.FileDialog(msoFileDialogFilePicker)If.Show -1 Then Exit Sub filePath=.SelectedItems(1)End With Open filePath For Input As#1 MyStr=StrConv(InputB(LOF(1),1),vbUnicode)Close#1 Set regEx=CreateObject(VBScript.RegExp)With regEx.Global=True.Pattern=d4/d1,2/d1,2 .Pattern=d4/d1,2/d1,2 Set Matches=.Execute(MyStr)If Matches.Count=0 Then Exit Sub ReDim brr(1 To Matches.Count,1 To 1)For i=1 To Matches.Count brr(i,1)=Matches(i-1)Next End With a1.Resize(i-1)=brr End Sub 18，提取指定字符串+5 个数字by:zamyi 2014-8-1 http:/ Function F$(R)With CreateObject(VBSCRIPT.REGEXP).Global=True .Pattern=(H|T|G|HM|WHM|Q|BQ|HQ|WQ|WBQ|WHQ|C|BC|HC|WC|WBC|WHC)d5 If.test(R(1)Then F=.Execute(R(1)(0)Else If R(2)Like P*Then F=Mid(R(2),3)End If End With End Function 用法：=F(C2:D2)19，提取指定字符串前面的数字 2014-9-19 http:/ Function yy(aa)Dim bb,reg,x,m Set reg=CreateObject(vbscript.regexp)With reg.Global=True.MultiLine=True bb=0.Pattern=(d+)小时 If.test(aa)Then Set m=.Execute(aa)For Each x In m bb=bb+x.SubMatches(0)Next End If.Pattern=(d+)分钟 If.test(aa)Then Set m=.Execute(aa)For Each x In m bb=bb+x.SubMatches(0)/60 Next End If bb=WorksheetFunction.Round(bb,2)End With yy=bb End Function 20，提取指定字符串前后的字符串 2015-4-17 http:/ Sub test()Dim arr,regx,i%,k,mh,j&With Range(a1).CurrentRegion.Resize(,2).Columns(2).ClearContents arr=.Value End With Set regx=CreateObject(vbscript.regexp)regx.Pattern=一-龥*希望 一-龥+regx.Global=True For i=1 To UBound(arr)Set mh=regx.Execute(arr(i,1)For j=0 To mh.Count-1 arr(i,2)=arr(i,2)&,&mh(j)Next arr(i,2)=Mid(arr(i,2),2)Next Range(a1).Resize(UBound(arr),2)=arr End Sub
