|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
仅供参考
Sub aa()
Selection.StartOf wdStory
With Selection.Find
.Text = "组成：*^13"
.Forward = True
.MatchWildcards = True
Do While .Execute
.Parent.MoveStart , 3
.Parent.MoveEnd , -1
排串 = Selection
a = 排汉字药量(排串)
If a <> "" Then Selection = a
Selection.Move
Loop
End With
End Sub
Function ChineseToNumber(ByVal s) '汉字转阿拉伯，数值不超过万。
Dim arr(1 To 2)
If s = "" Then Exit Function
If Right(s, 1) = "半" Then s = s & Mid(s, Len(s) - 1, 1)
If Left(s, 1) = "钱" Then s = "一" & s '调整为标准计量单位
Set dic = VBA.CreateObject("scripting.dictionary")
数值组 = Split("1, 10000, 1000, 100, 10, 1, 1, 1, 1, 1, 1,0,1,2,3,4,5,6,7,8,9,10,100,1000,0.5", ",")
For i = 0 To UBound(数值组)
dic(Mid("升斤两钱分厘枚段片粒个零一二三四五六七八九十百千半", i + 1, 1)) = 数值组(i)
Next i
flag = 1
For i = 1 To Len(s)
m = Mid(s, i, 1) '此处m肯定不为空。
Select Case m
Case "零", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "百", "千", "半"
nub1 = nub1 + dic(m)
Case "十", "百", "千"
nub2 = nub2 + nub1 * dic(m)
nub1 = 0
Case "升", "斤", "两", "钱", "分", "厘", "枚", "段", "片", "粒", "个"
nub3 = nub3 + (nub1 + nub2) * dic(m) 'instr前加0，防止当m为空时，显示start值，默认为1，但程序报错。
If flag = 1 Then fir = m: flag = 2
nub1 = 0: nub2 = 0
End Select
Next i
arr(1) = fir: arr(2) = nub3
ChineseToNumber = arr
End Function
Function 排汉字药量(ss)
Dim arr(1 To 2)
量名 = Array("升", "斤", "两", "钱", "分", "厘", "枚", "段", "片", "粒", "个")
Set dic = VBA.CreateObject("scripting.dictionary")
Set reg = VBA.CreateObject("vbscript.regexp")
With reg
.Global = True
.Pattern = ".*。([^升斤两钱分厘枚段片粒个]+。$)"
尾符 = IIf(.test(ss), .Replace(Selection, "$1"), "")
.Pattern = "[^、。]*?(([零一二三四五六七八九十百千半]+[升斤两钱分厘枚段片粒个]半?|钱半)+)[^、。]*"
Set jj = .Execute(ss) '取药名及数量集
If jj.Count = 0 Then 排汉字药量 = "": Exit Function
For Each 药名数量 In jj
药量 = 药名数量.submatches(0)
brr = ChineseToNumber(药量)
If Not dic.Exists(brr(1)) Then Set dic(brr(1)) = CreateObject("scripting.dictionary")
If Not dic(brr(1)).Exists(brr(2)) Then
arr(1) = 药名数量
Set dic(brr(1))(brr(2)) = CreateObject("scripting.dictionary")
dic(brr(1))(brr(2)) = arr
Else
temp = dic(brr(1))(brr(2))
temp(1) = temp(1) & "、" & 药名数量
If temp(2) = "" Then temp(2) = 药量 '假设不会同时出现一斤半与一斤五两这种现象。
dic(brr(1))(brr(2)) = temp
End If
Next
Set arrlist = VBA.CreateObject("system.collections.arraylist")
For Each 排量名 In 量名 '排序合并。
If dic.Exists(排量名) Then '量名按要求逐一取出存在值。
a = dic(排量名).keys '取出重量数组。
If UBound(a) > 0 Then
For Each b In a
arrlist.Add b
Next
arrlist.Sort '排序
a = arrlist.toarray
End If
For i = UBound(a) To 0 Step -1 '同一重量体系连接
tmp = dic(排量名)(a(i))
subtol = subtol & IIf(tmp(2) = "", tmp(1), Replace(tmp(1), tmp(2), "") & "，各" & tmp(2)) & "、"
Next i
tol = tol & subtol
subtol = "": arrlist.Clear
End If
Next
排汉字药量 = Left(tol, Len(tol) - 1) & "。" & 尾符
End With
End Function
|
|
楼主: 相见是缘8
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-7-18 00:23
