把每个药方中的每种药材，按数量的多少，重新先后排序

相见是缘8 · 发表于 2024-7-15 06:26

过客fppt 发表于 2024-7-14 09:30
因为我是直接在论坛上复制你的示例1写的，直接用变量str = "组成：附子（熟）10克、干姜6克、鸡子黄1个、 ...

过客 fppt 老师好！
感谢多次帮忙！实在是惭愧！我不会。

zds0616 · 发表于 2024-7-15 11:32

1、正则替换，数字前后添加制表符
2、split函数按、拆分为一维数组
3、join函数，用chr(13)连接

按以上生成的字符串，可直接粘贴到excel表格中，后面的排序什么的，想怎么弄就怎么弄，自由度也比较高。

zhanglei1371 · 发表于 2024-7-15 15:24

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

tcdatongye · 发表于 2024-7-15 17:12

汉字计量不方便比较大小，暂时未做。仅做了有数字的。

相见是缘8 · 发表于 2024-7-15 18:10

zhanglei1371 发表于 2024-7-15 15:24
sylun大师的代码太复杂，看不懂。
其实逻辑不难，但是很费劲，纯体力活。
只当做个练习。

zhanglei1371 老师好！

感谢援手！在我这测试的结果如图：

1、除图中箭头所指外，各字的前都少加了一个逗号。

2、第二段的药材名，不知什么原因替换后增加了不少。

相见是缘8 · 发表于 2024-7-15 18:20

tcdatongye 发表于 2024-7-15 17:12
汉字计量不方便比较大小，暂时未做。仅做了有数字的。

Tcdatongye 老师好！
感谢援手！能上传一个可复制的代码吗？
这样抄，很容易弄错。

相见是缘8 · 发表于 2024-7-15 18:24

zds0616 发表于 2024-7-15 11:32
1、正则替换，数字前后添加制表符
2、split函数按、拆分为一维数组
3、join函数，用chr(13)连接

zds0616 老师好！
感谢！你说的这些我还不会。

tcdatongye · 发表于 2024-7-15 18:35

Sub 宏1()
  Dim arr(1 To 2, 1 To 1000)
  nub = 1000
  Set dic = VBA.CreateObject("scripting.dictionary")
  Set reg = VBA.CreateObject("vbscript.regexp")
  a = VBA.Split("克、枚、段、片、粒、个", "、")
Selection.StartOf wdStory
With Selection.Find
      .Text = "组成：*^13"
      .Forward = True
      .MatchWildcards = True
      Do While .Execute
      .Parent.MoveStart , 3
      .Parent.MoveEnd , -1
      For i = 0 To UBound(a)
         dic(a(i)) = arr
      Next i
         With reg
         .Global = True
         .Pattern = "[^、。]*?(\d+)([克枚段片粒个])[^、。]*"
         Set jj = .Execute(Selection)
         If jj.Count = 0 Then GoTo 10
         For Each kk In jj
         temp = dic(kk.submatches(1)) '取出数组
         temp(1, kk.submatches(0)) = temp(1, kk.submatches(0)) & kk & "、" '给数组赋值
         temp(2, kk.submatches(0)) = temp(2, kk.submatches(0)) + 1 '统计合并数
         dic(kk.submatches(1)) = temp '新值的数组放进去
         Next kk
         For Each s In a
            For j = nub To 1 Step -1
            If dic(s)(1, j) <> "" Then
               If dic(s)(2, j) > 1 Then '重复次数
                  .Pattern = "\d+" & s & "|、$"
                  t = .Replace(dic(s)(1, j), "")
                  y = y & .Replace(dic(s)(1, j), "") & "，各" & j & s & "、"
                  Else
                  y = y & dic(s)(1, j)
               End If
            End If
            Next j
         Next
      End With
      Selection = Left(y, Len(y) - 1) & "。"
10:
      y = ""
      Selection.Move
      Loop
End With

End Sub

相见是缘8 · 发表于 2024-7-16 06:17

tcdatongye 发表于 2024-7-15 18:35
Sub 宏1()
Dim arr(1 To 2, 1 To 1000)
nub = 1000

Tcdatongye 老师好！

万分感谢！代码对数字药量排序几乎完美！但发现有一点，就是药材数量后面，如还有文字的会删除了（如图中所指），这个有办法完善吗？如太麻烦，或太难，就算了，如方便就劳你再修改一下，拜谢！

另外，第一次见代码运行时，如放幻灯片样（新奇），是为了让替换过程看得见，特意这样显示吗？

ming0018 · 发表于 2024-7-16 09:04

相见是缘8 发表于 2024-7-16 06:17
Tcdatongye 老师好！万分感谢！代码对数字药量排序几乎完美！但发现有一点，就是药材数量后面，如还有文 ...

您把所有情况都总结一下，基于各位同仁都是免费给您写的代码，不想一次又一次的改代码了，时间和精力都是有限的。
或者说您可能不能一次性总结出所有的可能性，这个我们也理解。但我们还是希望您能尽可能的把收集，总结的工作做好，这样大家配合起来，写代码心情也比较愉快。

		自动登录	找回密码
密码			免费注册

[求助] 把每个药方中的每种药材，按数量的多少，重新先后排序

评分

评分

评分