|
|
楼主 |
发表于 2019-2-13 22:01
|
显示全部楼层
本帖最后由 weiyingde 于 2019-3-17 19:25 编辑
4.提取指定类型的数据，或对夹杂有数字的单元格区域进行求和。
本函数有四个作用：
1、当 sr=“Gt”时，rng必须是单个的单元格，根据num的不同，有三个作用：
（1）num=1 ,提取指定单元格中的汉字；
（2）num=2，提取指定单元格中的英文字母；
（3）num=3,提取指定单元格中的数字；
2、当 sr=“Sm”时，rng必须是单元格区域，num=3
求指定单元格区域中所有所有数字的和。
代码如下：
Function 取数(rng As Range, sr As String, num As Integer, Optional ByVal fgf As String = "")
Dim regEx, Mth, Matches ' 建立变量。
Dim Patrn$, Nnmb As Integer
Numer = 0
Select Case sr
Case "Gt"
For Each rg In rng
m = m + 1
Next
If m >= 2 Then
MsgBox "取数(单元格引用,sr, num） " & Chr(10) & "sr=Gt 单元格引用必须是单个的"
取数 = "第一个参数错误"
Exit Function
End If
Select Case num
Case 1
Patrn = "[一-龥]"
Case 2
Patrn = "[A-Za-z]"
Case 3
Patrn = "[0-9]{1,}"
Case Else
MsgBox "取数(字符串或单元格引用,sr, num） " & Chr(10) & " num=1 提取汉字" & Chr(10) & " num=2 提取字母" & Chr(10) & " num=3 提取数字"
取数 = "第三个参数错误"
Exit Function
End Select
Set regEx = CreateObject("vbScript.regexp") 'New RegExp ' 建立正则表达式。
regEx.Pattern = Patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全局替换。
'regEx.MultiLine = True '设置多行匹配。
Set Matches = regEx.Execute(rng.Text) ' 执行搜索。
If num = 1 Or num = 2 Then
For Each Mth In Matches ' 遍历 Matches 集合。
RetStr = RetStr & fgf & Mth
Next
ss = Mid(RetStr, Len(fgf) + 1)
Else
ss = Matches(0)
End If
取数 = IIf(num = 3, Val(ss), ss)
Set regEx = Nothing
ss = ""
Case "Sm"
If num <> 3 Then
MsgBox "取数(字符串或单元格引用,sr, num） " & Chr(10) & " sr=Sm 区域数字求和" & Chr(10) & " num=3(必须为3)"
取数 = "第三个参数错误"
Exit Function
End If
For Each rg In rng
n = n + 1
Next
If n = 1 Then
MsgBox "取数(单元格引用,sr, num） " & Chr(10) & "当sr=Sm时 单元格引用必须是区域的"
取数 = "第一个参数错误"
Exit Function
End If
For i = 1 To n
ss = ss & rng.Item(i).Text
Next
Set regEx = CreateObject("vbScript.regexp") 'New RegExp ' 建立正则表达式。
regEx.Pattern = "[0-9]{1,}" ' 设置模式
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全局替换。
'regEx.MultiLine = True '设置多行匹配。
Set Matches = regEx.Execute(ss) ' 执行搜索。
For Each Mth In Matches
Numer = Numer + Val(Mth)
Next
取数 = Val(Numer)
Set regEx = Nothing
Set Matches = Nothing
Case Else
MsgBox "取数(单元格引用,sr, num）第二参数只能是：" & Chr(10) & "sr = Gt" & Chr(10) & "sr = Sm"
取数 = "第二个参数错误"
Exit Function
n = 0: m = 0: ss = ""
End Select
End Function
再加上一个Function f_sum(a As String) As Double
Dim dis As Object, b As Variant
Application.Volatile
Set dis = CreateObject("vbscript.regexp")
With dis
.Global = True
.Pattern = "\-?\d+\.?\d*"
If .test(a) Then
For Each b In .Execute(a)
f_sum = f_sum + Val(b)
Next b
End If
End With
End Function
示例附件如下：
补充内容 (2019-10-20 12:37):
附香川群子的函数如下：
Function TQ(txt$, Optional k = 0, Optional pt = 1, Optional s$ = "")
If IsNumeric(pt) Then pt = Choose(pt, "\w", "[^a-zA-Z]", "\D", "[^a-z]", "[^A-Z]", "\W", "\d")
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = pt
If .test(txt) Then
If k = 0 Then
TQ = .Replace(txt, s)
ElseIf k > 0 Then
If InStr(k, ".") Then
Set Ma = .Execute(txt)
ReDim a(Ma.Count - 1)
For Each m In Ma
a(c) = m
c = c + 1
Next
If s = "" Then s = " "
TQ = Join(a, s)
Else
TQ = .Execute(txt)(k - 1) '.Execute(txt)(0)
End If
Else 'If k < 0 Then TQ = .Execute(txt)(0).SubMatches(1)
If InStr(k, ".") Then
TQ = .Execute(txt)(Int(-k) - 1).SubMatches(Mid(k, InStr(k, ".") + 1) - 1)
Else
Set sMa = .Execute(txt)(-k - 1).SubMatches
ReDim a(sMa.Count - 1)
For Each m In sMa
a(c) = m
c = c + 1
Next
If s = "" Then s = " "
TQ = Join(a, s)
End If
End If
Else
' Stop
If k = 0 And s = "" Then TQ = txt Else TQ = ""
End If
End With
End Function
补充内容 (2019-10-31 18:44):
Public Function HZGet(ByVal strscr As String) As String
Dim i As Integer
For i = 1 To Len(strscr)
'汉字小于ASC值0﹐否则在0-127之间
If Asc(Mid(strscr, i, 1)) < 0 Then
HZGet = HZGet & Mid(strscr, i, 1)
End If
Next i
HZGet = HZGet
End Function
补充内容 (2019-10-31 18:46):
函数作用:字符型转数字型
'################################################################
Private Function TxtCData()
Dim Sel As Range
Dim TRow As Long, BRow As Long
Dim LCou As Long, RCou As Long
Set Sel = Range(Selection.Address)
TRow = Sel.Row
BRow = TRow + Sel.Rows.Count - 1
LCou = Sel.Column
RCou = LCou + Sel.Columns.Count - 1
For C = LCou To RCou
For R = TRow To BRow
If Cells(R, C).NumberFormatLocal = "@" And IsNumeric(Cells(R, C).Value) = True Then
Cells(R, C).NumberFormatLocal = "G/通用格式"
If Cells(R, C).Value <> vbNullString Then _
Cells(R, C).Value = Val(Cells(R, C).Value)
End If
Next
Next
Set Sel = Nothing
End Function |
|
楼主: weiyingde
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-2-7 22:16
