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

tcdatongye

不知具体情况，代码仅供参考。

相见是缘8

tcdatongye 发表于 2024-7-19 19:11
仅供参考
Sub aa()
Selection.StartOf wdStory

Tcdatongye 老师好！

辛苦了，感谢！

代码我在“模拟附件”上运行不了，提示如图，麻烦你给看看，多谢！

tcdatongye

可能版本低的原因。这就是个排序程序。有很多现成的。你找一个加进去就行了。你不会还在用2003吧？现在都用2016了。

相见是缘8

Tcdatongye 老师好！我的是2003，用的是公司的电脑，公司的仓储软件，它绑死了2003，不能升级。

zpy2

相见是缘8 发表于 2024-7-17 06:29
Tcdatongye 老师好！
真心感谢！数字药量排序代码完美达愿！
真是会者不难，难者不会！这么麻烦难缠的 ...

Set unitValues = New Collection
    unitValues.Add 100000000000#, "升"
    unitValues.Add 10000000000#, "斤"
    unitValues.Add 1000000000, "两"


这种 中文 对应 阿拉伯数字的对照表 有没？

转变为阿拉伯数字才能排序啊

tcdatongye

相见是缘8 发表于 2024-7-20 10:25
Tcdatongye 老师好！我的是2003，用的是公司的电脑，公司的仓储软件，它绑死了2003，不能升级。

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)
          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
  
  
    For Each 排量名 In 量名 '排序合并。
      If dic.Exists(排量名) Then '量名按要求逐一取出存在值。
        a = dic(排量名).keys '取出重量数组。
        Call 插入排序(a)
        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 = ""
      End If
    Next
    排汉字药量 = Left(tol, Len(tol) - 1) & "。" & 尾符

End With
End Function
Function 插入排序(arr)
a = LBound(arr) + 1: b = UBound(arr)
For i = a To b
  tp = arr(i)
  For j = i To a Step -1
    If arr(j - 1) > tp Then
        arr(j) = arr(j - 1)
      Else
        Exit For
    End If
  Next j
If arr(j) <> tp Then arr(j) = tp
Next i
End Function

tcdatongye

相见是缘8 发表于 2024-7-20 10:25
Tcdatongye 老师好！我的是2003，用的是公司的电脑，公司的仓储软件，它绑死了2003，不能升级。

结果：
主治：温热病，热邪内陷心包，痰热壅闭心窍。
特征：高热烦燥，神昏谵语，以及中风昏迷，小儿惊厥属邪热内闭者。
紫雪丹：
组成：硝石四升、饴糖一升、芒硝十斤、寒水石三斤半、石膏二斤六两、磁石一斤八两、玄参、白术，各一斤半、熟地一斤二两四钱、滑石、升麻，各一斤、生地半斤、黄金一百两、炙甘草八两六钱、川芎八两、羚羊角（屑）五两二钱、水牛角浓缩粉、沉香、青木香，各五两、朱砂、独活，各三两、丁香一两九钱、生姜一两三钱（碎）、防风六钱三分、甘草、白芍，各六钱、细辛、黄芩，各四钱、秦艽钱半、当归一钱三分、羌活一钱二分、石羔七分二厘、麝香五分六厘、茯苓五分、白芷四厘、红枣十二枚（切开）、葱白三段、荷叶二片（剪条）、花椒子六十粒（捣碎）、鸡子黄三个。
功用：清热开窍，镇痉安神。
主治：温热病，热邪内陷心包。

麻黄汤：
组成：元参半斤、熟地二两、麦冬一两、甘菊花、牛膝，各五钱、天门冬三钱、黄柏五分、三七根（末）三分、龙骨（煅，醋焠）七厘、水银一厘、红枣十四枚、附子一枚、竹叶二十四片、柳树叶九片、北味十粒、桃仁五粒。水煎服。
功用：发汗解表，宣肺平喘。
主治：外感风寒。
特征：恶寒发热，头痛身疼，无汗而喘，舌苔薄白，脉浮紧。
附方：
1、麻黄加术汤：
组成：薏仁二两、芡实一两、茯苓三钱半、牛膝二钱、萆薢一钱四分、肉桂一钱。水煎服。
功用：发汗解表，散寒祛湿。
主治：湿家身烦疼痛。
2、麻杏苡甘汤：
组成：薏仁二两一钱、革麻一两半、茯苓一两二钱、白术五钱、芡实三钱六分、杜仲三钱、肉桂一钱七分、亇膝一钱。水煎服。
功用：解表祛湿。
主治：风湿一身疼痛。
特征：发热日甚。

tcdatongye

zpy2 发表于 2024-7-20 10:59
Set unitValues = New Collection
    unitValues.Add 100000000000#, "升"
    unitValues.Add 100000 ...

可以自己设定。见zhanglei1371程序，我也是根据他的用法做的。

相见是缘8

zpy2 发表于 2024-7-20 10:59
Set unitValues = New Collection
    unitValues.Add 100000000000#, "升"
    unitValues.Add 100000 ...

zpy2 老师好！
感谢回复！
这个 “阿拉伯数字的对照表”，我没有。我对 VBA，还处在免强会用的阶段，编写代码，水平还未到。

相见是缘8

tcdatongye 发表于 2024-7-20 12:17
结果：
主治：温热病，热邪内陷心包，痰热壅闭心窍。
特征：高热烦燥，神昏谵语，以及中风昏迷，小儿惊 ...

Tcdatongye 老师好！

辛苦、辛苦！衷心拜谢！

代码，我在“模拟附件”上测试了，除了有一点如图现象外（我手动修改，即可），完美！我发现老师言语不多，技术却扛扛的！真心佩服！再次感谢老师！