中医药方整理的难题，想练手的来试试

于箱长

sunya_0529 发表于 2024-9-27 16:22
感谢兄台分享，大概翻了翻，内容太详细了~

就是文件有点大，还得分卷压缩，我嫌麻烦就直接分享了个链接，但是网盘有一个问题就是不知道啥时就失效了

PurpleIdea

sunya_0529 发表于 2024-9-24 18:34
用Excel也没问题的

尝试写了一下附方1，代码有点乱，非标的东西太多了，只能大概生成（不完全一样）。

过客fppt

参与过最简单的一类排序：

过客fppt

过客fppt 发表于 2024-9-28 10:58
参与过最简单的一类排序：

1. Sub 药材按升斤排序()
   
2.     Dim arr, crr(), drr, err
   
3.     Dim i%, j%, k%, l%, index%, ShuJC%
   
4.     Dim str As String, s As String
   
5.     Dim brr() As String, ShuJurr
   
6.     str = "组成：附子（熟）10克、干姜6克、鸡子黄1个、花椒子13粒（捣碎）。人参6克、白术（炙）10克、茯苓10克、陈皮6克、甘草（炙）6克、五味子3克、半夏（洗，去滑）10克、生姜3片、红枣4枚（切开）。"
   
7. 
   
8.     arr = Split("克、枚、段、片、粒、个", "、")
   
9.     str = Replace(str, "组成：", "")
   
10.     str = Left(str, Len(str) - 1)
    
11.     str = Replace(str, "。", "、")
    
12.    
    
13.     brr = Split(str, "、")
    
14.     ReDim drr(LBound(brr) To UBound(brr))
    
15.     ReDim crr(LBound(brr) To UBound(brr), 1 To 3) '表格
    
16.     '正则表达式
    
17.     Dim reg As Object
    
18.     Dim Ma
    
19.    
    
20.     Set reg = CreateObject("VBScript.RegExp")
    
21.     For i = LBound(brr) To UBound(brr)
    
22.         With reg
    
23.             .Global = False
    
24.             .IgnoreCase = True '不区分大小写
    
25.             .Pattern = "\d{1,}" '正则表达式
    
26.             Set Ma = .Execute(brr(i)) '返回在文本中匹配的集合
    
27.             '拆分为表格
    
28.             crr(i, 1) = Left(brr(i), Ma(0).firstindex)
    
29.             crr(i, 2) = mid(brr(i), Ma(0).firstindex + 1, Ma(0).Length)
    
30.             crr(i, 3) = Right(brr(i), Len(brr(i)) - Ma(0).Length - Ma(0).firstindex)
    
31.         End With
    
32.     Next i
    
33. 
    
34.     二维数组排序3 crr, 2
    
35.     i = 0
    
36.    
    
37.     '重新组合
    
38.     ReDim ShuJurr(LBound(crr) To UBound(crr))
    
39.     For i = LBound(crr) To UBound(crr)
    
40.         ShuJurr(i) = crr(i, 1) & crr(i, 2) & crr(i, 3)
    
41.     Next
    
42.    
    
43.     '"克、枚、段、片、粒、个"排序
    
44.     For i = LBound(arr) To UBound(arr)
    
45.         For j = LBound(ShuJurr) To UBound(ShuJurr)
    
46.             If InStr(ShuJurr(j), arr(i)) Then
    
47.                 drr(k) = ShuJurr(j)
    
48.                 k = k + 1
    
49.             End If
    
50.         Next
    
51.     Next
    
52.    
    
53.     '文字输出
    
54.     For i = LBound(drr) To UBound(drr)
    
55.         s = s & drr(i) & "、"
    
56.     Next
    
57. End Sub
    
58. Sub 二维数组排序3(ByRef arr() As Variant, WeiDu As Integer)
    
59.     Dim numRows As Integer, i As Integer, j As Integer, k As Integer
    
60.     Dim s As Single, s1 As Single
    
61.     numRows = UBound(arr) - LBound(arr) + 1
    
62.    
    
63.     Dim temp()
    
64.     ReDim temp(LBound(arr, 2) To UBound(arr, 2))
    
65.    
    
66.     For i = 0 To numRows - 1
    
67.         For j = 0 To numRows - 2
    
68.             s = arr(j, WeiDu)
    
69.             s1 = arr(j + 1, WeiDu)
    
70.             If s > s1 Then
    
71.                 ' 交换位置
    
72.                 For k = LBound(arr, 2) To UBound(arr, 2)
    
73.                     temp(k) = arr(j, k)
    
74.                     arr(j, k) = arr(j + 1, k)
    
75.                     arr(j + 1, k) = temp(k)
    
76.                 Next
    
77.             End If
    
78.         Next j
    
79.     Next i
    
80. End Sub

复制代码

PurpleIdea

过客fppt 发表于 2024-9-28 10:58
参与过最简单的一类排序：

你这代码好简洁啊，厉害！！！

过客fppt

PurpleIdea 发表于 2024-9-28 11:06
你这代码好简洁啊，厉害！！！

过奖过奖，都是向大佬学习的结果

sunya_0529

过客fppt 发表于 2024-9-28 10:58
参与过最简单的一类排序：

这个按计量单位的顺序，数值升序排列，功能可以了

sunya_0529

PurpleIdea 发表于 2024-9-27 18:04
尝试写了一下附方1，代码有点乱，非标的东西太多了，只能大概生成（不完全一样）。

认真看了一下代码细节，数值的转换非常精准，点赞！

看得出来花了很多心思和时间，在处理“非标”中文计量单位时，用字典索引的办法也是个不错的思路，毕竟再“非标”，其实也就是那几种。

咱们刚开始写代码的时候，一般不太会考虑代码的复用，用简单的逻辑堆出来之后再想办法用循环代替重复较多的部分，用函数来代替固定的输入和输出部分。

目前的要求是按需求把药方整理排序，代码长短以及执行效率，以及代码是否优化重构，都可以先放一放。

与祖国母亲同庆盛世华诞，节日快乐

sunya_0529

受E友@PurpleIdea启发，很多老铁应该喜欢在Excel中创作，所以把数据挪到Excel里——

PurpleIdea

sunya_0529 发表于 2024-10-1 08:54
认真看了一下代码细节，数值的转换非常精准，点赞！

看得出来花了很多心思和时间，在处理“非标”中文 ...

多谢版主的认可