|
|
sylun大师的代码太复杂，看不懂。
其实逻辑不难，但是很费劲，纯体力活。
只当做个练习。
仅适用于中文数字的情况。操作见视频演示。
中药按数量排序[EH论坛的一个问题]_哔哩哔哩_bilibili https://www.bilibili.com/video/BV1xW421R7JG/?pop_share=1
ZLtest.rar
(20.09 KB, 下载次数: 1)
代码如下：
Sub zltest()
'仅适用于中文单位的情况,数字形式已有网友写出,不再重复书写。
'代码仅供参考,无后续修改服务,不挤面条。有其他需求请自己修改或AI,否则就付费定制QQ625289295！
Dim arr(1000, 1)
Dim brr, pa As Paragraph, rg As Range
ActiveDocument.Range.Find.Execute "([!一二三四五六七八九十])钱半", , , 1, , , , , , "\1一钱半", 2
chnum = "一二三四五六七八九十百"
Code = "升斤两克钱分厘枚段片粒个"
'关键正则表达式★★★
pat = "([^、：。一二三四五六七八九十0-9]+?)([一二三四五六七八九十升斤两钱分厘枚段片粒个半]+)(半)?([（剪条切开捣碎）]*)?(?=[。：、])"
Set re = CreateObject("vbscript.regexp")
re.Global = -1
re.MultiLine = -1
re.IgnoreCase = -1
re.Pattern = pat
For p = 1 To ActiveDocument.Paragraphs.Count
Set pa = ActiveDocument.Paragraphs(p)
firstNum = 0
If re.test(pa.Range.Text) Then
For Each Ma In re.Execute(pa.Range.Text)
If firstNum = 0 Then firstNum = pa.Range.Start + Ma.firstindex
EndNum = pa.Range.Start + Ma.firstindex + Ma.Length
arr(i, 0) = ConvertWeight(Ma.submatches(1) & Ma.submatches(2))
arr(i, 1) = Ma.value
i = i + 1
Next
brr = zl排序(arr)
For i = 0 To UBound(brr)
Set Ma1 = re.Execute(brr(i, 1) & "、")
If brr(i + 1, 1) <> "" Then
Set Ma2 = re.Execute(brr(i + 1, 1) & "、")
药名1 = Ma1(0).submatches(0)
数量1 = Ma1(0).submatches(1)
数量2 = Ma2(0).submatches(1)
Else
数量2 = "我思故我在！"
End If
If 数量1 <> 数量2 Then
If zltf = False Then
strA = strA & brr(i, 1)
sep = "，"
Else
strA = strA & 药名1 & "各" & 数量1
sep = "，"
zltf = False
End If
Else
zltf = True
strA = strA & 药名1
sep = "、"
End If
If brr(i + 1, 1) <> "" Then
strA = strA & sep
Else
'strA = strA & "。"
Exit For
End If
Next
If strA <> "" Then
Set rg = ActiveDocument.Range(firstNum, EndNum)
rg.Font.Color = vbBlue
rg.Text = strA
strA = ""
End If
End If
Next
MsgBox "已完成！"
End Sub
Function zl排序(ByRef arr As Variant) '作用：排序;
Dim i As Long, j As Long
Dim temp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i, 0) < arr(j, 0) Then
temp = arr(i, 0)
arr(i, 0) = arr(j, 0)
arr(j, 0) = temp
temp = arr(i, 1)
arr(i, 1) = arr(j, 1)
arr(j, 1) = temp
End If
Next j
Next i
zl排序 = arr
End Function
Function ConvertWeight(weight As String) As Double '作用：单位转换为数字倍数
Dim regex As Object
Dim matches As Object
Dim match As Object
Dim unitValues As Collection
Dim total As Double
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = False
regex.Pattern = "([一二三四五六七八九十半]+)(升|斤|两|克|钱|分|厘|枚|段|片|粒|个)(半)?"
Set unitValues = New Collection
unitValues.Add 100000000000#, "升"
unitValues.Add 10000000000#, "斤"
unitValues.Add 1000000000, "两"
unitValues.Add 100000000, "克"
unitValues.Add 10000000, "钱"
unitValues.Add 1000000, "分"
unitValues.Add 100000, "厘"
unitValues.Add 10000, "枚"
unitValues.Add 1000, "段"
unitValues.Add 100, "片"
unitValues.Add 10, "粒"
unitValues.Add 1, "个"
Set matches = regex.Execute(weight)
total = 0
For Each match In matches
Dim value As Single
Dim unit As String
value = ConvertSpecialCases(match.submatches(0))
unit = match.submatches(1)
ban = match.submatches(2)
If InStr("升斤两克钱分厘枚段片粒个", unit) Then
total = total + value * unitValues(unit)
End If
If ban = "半" Then
total = total + 0.5 * unitValues(unit)
End If
Next match
ConvertWeight = total
End Function
Function ConvertSpecialCases(inputStr As String) As Double '作用：处理半
If inputStr = "半" Then
value = 0.5
ElseIf InStr(inputStr, "半") > 0 Then
Dim parts() As String
parts = Split(inputStr, "半")
value = ChineseToNumber(parts(0)) + 0.5
Else
value = ChineseToNumber(inputStr)
End If
ConvertSpecialCases = value
End Function
Function ChineseToNumber(chineseNum As String) As Long '作用：汉字转阿拉伯
Dim digits As String
Dim i As Long
Dim number As Long
Dim placeValue As Long
digits = "十一二三四五六七八九"
placeValue = 1
number = 0
For i = Len(chineseNum) To 1 Step -1
Dim digit As String
digit = Mid(chineseNum, i, 1)
If InStr(digits, digit) > 0 Then
number = number + (InStr(digits, digit) - 1) * placeValue
placeValue = placeValue * 10
End If
Next i
ChineseToNumber = number
End Function
|
评分
-
1
查看全部评分
-
|
楼主: 相见是缘8
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-7-15 11:32
