修改次序混乱不同的数量单位和重复的数量单位

413191246se · 发表于 2022-9-7 07:34

* 说了那么多，最后还是漏了一点：我现在的心愿，就是想让标准模块 NewMacros.bas 文件大小，小于 100kb，宏数量少于 100 个。现有宏 145 个左右，感觉太多。

* 另外，空白通用模板 Normal.dot(m) 中存储标准模块 NewMacros 的代码。代码越少，Word 越稳定，越不易崩溃。但是我感觉，无论是 Word 2003，还是 Word 2019（Word 2007 也用过）都是相当地容易崩溃（比如在用通配符查找替换时）。——很不喜欢有太多的代码，但想让代码简洁高效，又很难做到。

* 我用 Word 很多年了，略会录制宏；但真正入门 VBA 宏，是 2011年7月左右（此前自学过一段 VB6，但没看明白，连“计算器”都没编出来）。到目前为止，也有 11 年了，虽然认识到水平不高，但没关系，做一个 Word VBA 业余程序员很好的，编程是一种兴趣、乐趣，也在实际工作中有所应用，利己利人，也就乐此不疲了！（前两天，我默背“小九九”表，我背成 7 x 9 = 83 了！想了好久，才想起来是 63，实话实说。网上说这也是一道编程题，我想有时间用 VBA 试试编出来。）

* 昨天在本论坛搜索了兄台的帖子学习了一会儿。虽然过去也有学过，但几乎没怎么收藏，因为不少看不懂。——现在我和兄台电脑配置一样，都是 Win10x64 + Office2019；我为了能在 Word 2003 中编写代码，还特意在去年12月底购买了一款二手笔记本电脑（Win7+Word2003），要价 299 元，我给 335 元让其送货上门。最近经常用它，特别是夏季太热，我怕热坏了我的联想品牌机（主机 7999元，联想商城购买；飞利浦显示器 43.2 寸，京东购买），一到九点半我就关机，改用笔记本电脑，感觉良好。最近天气凉了，也不必用笔记本电脑了，但一到晚上 11点左右，想编程吧，又感觉头脑昏沉，精力疲惫，遂改为睡觉。

* 我前几天，又试验了一下，让自动宏 AutoOpen 打开文档就自动打开窗体（窗体有自定义宏按钮），但我又想让用户及我按“加载项”选项卡（比窗体容易一些），究竟哪个主意更好呢？兄台要是想用自定义宏按钮，是想用“窗体”还是想用“加载项”选项卡呢？（gbgbxgb 老师说我很老，但我认为我有点儿老，但不是太老，我心理还是很年轻的！热情无限，水平有限。活到老学到老，编程有乐趣！向论坛各位老师学习！）

* 祝论坛各位版主、管理员、前辈、老师、朋友：中秋节快乐！合家欢乐！身体健康！万事如意！

sylun · 发表于 2022-9-7 23:07

本帖最后由 sylun 于 2022-9-8 00:38 编辑

相见是缘8 发表于 2022-9-5 08:21
sylun老师好！真是惭愧和感激！因本人实在是个外行，不能一次准确描述所有问题，导致要求多变，难为和让 ...

上一个代码是存在一些问题，现根据楼主的要求一并进行修改，适应范围扩大到百位数，数量单位增加了“升”、“克”两字，楼主可随意增减，但“几”字不算。当然更新后的代码还会存在问题，主要是对“半”字及标点符号的处理上。因复杂文本处理太费神，且视力不济，所以还得请楼主详细检试，并具体描述存在问题（最好在标注不同颜色的同时再以上文字归纳问题）
昨晚回复发不出，不知什么原因。看看这次另帖发能否发出

sylun · 发表于 2022-9-7 23:11

本帖最后由 sylun 于 2022-9-8 22:25 编辑

更新后的代码1，请测试

Private num(0 To 999) As String
Sub test5()
Dim i%, j%, k%, m%, n%, r%, s%, code$, data$, data2$
Dim info(), info1&(), info2$(), data1()
Dim RegExp As Object
Dim Match As Object
Dim RegExp2 As Object
Dim Match2 As Object
Call NumToCnNum
data = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content.Text, Selection.Text)
code = "升斤两克钱分厘枚粒片" '数量单位据此先后排序
Set RegExp = CreateObject("VBScript.RegExp")
Set RegExp2 = CreateObject("VBScript.RegExp")
With RegExp
.Global = True
.Pattern = "(([^。；：、\r]*[^升斤两克钱分厘枚粒片半、]、)*?[^。；：、\r]+(（[^）]+）)?)([十九八七六五四三二一半百]+)([①-⑩]?)([升斤两克钱分厘枚粒片])([①-⑩半]?(（[^）]+）)?)(?=[。，、])"
If .test(data) = False Then
MsgBox "找不到匹配，程序退出！", vbCritical
Exit Sub
End If
For Each Match In .Execute(data) '获取匹配方剂各药材配伍文本相关定位参数
ReDim Preserve info(8, i)
With Match
info(0, i) = .Value
info(1, i) = .Length
info(2, i) = .firstindex
info(3, i) = info(1, i) + info(2, i) + 1
info(4, i) = .submatches(0)
info(5, i) = .submatches(3)
info(6, i) = .submatches(4)
info(7, i) = .submatches(5)
info(8, i) = .submatches(6)
End With
i = i + 1
Next
End With
If i > 1 Then
r = 0
For j = 1 To i - 1
If info(2, j) <> info(2, j - 1) + info(1, j - 1) + 1 Then '对目标文本按匹配配伍与相邻字符串依次进行分组
ReDim Preserve info1(4, n)
If j - r > 1 Then '有两个以上匹配相连时合并为一组
info1(0, n) = r
info1(1, n) = j - 1
info1(2, n) = info(2, r) + 1
info1(3, n) = info(2, j - 1) - info(2, r) + info(1, j - 1) + 1
info1(4, n) = 1
r = j
n = n + 1
ReDim Preserve info1(4, n)
info1(0, n) = r
info1(1, n) = j - 1
info1(2, n) = info(3, j - 1)
info1(3, n) = info(2, j) - info(3, j - 1) + 1
info1(4, n) = 0
Else
info1(0, n) = r
info1(1, n) = j - r
info1(2, n) = info(3, j - 1) + 1
info1(3, n) = info(2, j) - info(3, j - 1)
info1(4, n) = 0
If n > 0 Then
If info1(4, n - 1) = 0 Then
info1(2, n) = info(2, j - 1) + 1
info1(3, n) = info(2, j) - info(2, j - 1)
End If
End If
r = j
End If
n = n + 1
End If
Next
ReDim Preserve info1(4, n) '目标文本前部没有匹配的字符串
info1(0, n) = r
info1(1, n) = j - 1
info1(2, n) = info(2, r) + 1
info1(3, n) = info(3, j - 1) - info1(2, n) + 1
info1(4, n) = 1
If Len(data) > info1(2, n) + info1(3, n) Then '目标文本末尾没有匹配的字符串
n = n + 1
ReDim Preserve info1(4, n)
info1(0, n) = r
info1(1, n) = j - 1
info1(2, n) = info(2, j - 1) + info(1, j - 1) + 1
info1(3, n) = Len(data) - info1(2, n)
End If
ReDim data1(6, UBound(info1, 2))
For k = 0 To UBound(data1, 2)
data1(0, k) = info1(0, k)
data1(1, k) = info1(1, k)
data1(2, k) = info1(2, k)
data1(3, k) = info1(3, k)
data1(4, k) = Mid(data, info1(2, k), info1(3, k))
data1(5, k) = info1(4, k)
Next
ReDim info2(UBound(data1, 2))
For i = 0 To UBound(data1, 2)
If data1(5, i) = 1 Then
s = s + 1
For j = 1 To Len(code) '处理方剂药材配伍文本
For k = 99 To 0 Step -1 '对提取的药材以剂量大小进行排序
For m = data1(0, i) To data1(1, i)
If info(7, m) = Mid(code, j, 1) And info(5, m) = num(k) Then info2(i) = info2(i) & info(0, m) & "、"
Next
Next
Next
For m = 1 To Len(code) '处理判断为相同数量及单位的药材
If info2(i) <> Empty Then
With RegExp2
.Global = True
.Pattern = "([^、；。]+?)◆?各?([十九八七六五四三二一半]+)([①-⑩]?)(" & Mid(code, m, 1) & "半?)([①-⑩]?(（[^）]+）)?)、([^、。]+?)◆?各?\2\4([①-⑩]?（[^）]+）)?([、，。]|$)"
If InStr(info2(i), Mid(code, m, 1)) Then
Do While .test(info2(i)) = True
info2(i) = .Replace(info2(i), "$1$3$5◇$7$8◆各$2$4$9")
Loop
.Pattern = "[◇，、]+"
info2(i) = .Replace(info2(i), "、")
.Pattern = "[◆，]+"
info2(i) = .Replace(info2(i), "，")
End If
.Pattern = "，?(，各[十九八七六五四三二一半]+" & Mid(code, m, 1) & ")[、，；。](.+?\1)(?=[、，；。])"
info2(i) = .Replace(info2(i), "、$2")
End With
End If
Next m
data1(6, i) = "△" & Left(info2(i), Len(info2(i)) - 1) & "▲"
Else
data1(6, i) = data1(4, i)
End If
Next
End If
data2 = Left(data, data1(2, 0) - 1)
For i = 0 To UBound(data1, 2)
data2 = data2 & data1(6, i)
Next
With IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
For i = 0 To UBound(data1, 2)
If data1(5, i) = 1 Then
If Selection.Type = wdSelectionIP Then
.SetRange data1(2, i) - 1, data1(2, i) + data1(3, i) - 2
Else
.SetRange Selection.Start + data1(2, i) - 1, Selection.Start + data1(2, i) + data1(3, i) - 2
End If
.HighlightColorIndex = wdYellow '在原文档突出显示匹配文本
End If
Next
End With
With Documents.Add(ActiveDocument.FullName).Content.Find
.Parent.Text = data2 '将处理结果输出到以原文档为模板的新文档
.Replacement.Highlight = True
.Execute "△*▲", MatchWildcards:=True, replacewith:="^&", Replace:=wdReplaceAll
End With
MsgBox "共处理了" & s & "条，处理条目见原文档标记、结果文本见新文档突出显示部分。"
End Sub

复制代码

sylun · 发表于 2022-9-7 23:14

本帖最后由 sylun 于 2022-9-8 00:37 编辑

相见是缘8 发表于 2022-9-5 08:21
sylun老师好！真是惭愧和感激！因本人实在是个外行，不能一次准确描述所有问题，导致要求多变，难为和让 ...

上一个代码是存在一些问题，现根据楼主的要求一并进行修改，适应范围扩大到百位数，数量单位增加了“升”、“克”两字，楼主可随意增减，但“几”字不算。当然更新后的代码还会存在问题，主要是对“半”字及标点符号的处理上。因复杂文本处理太费神，且视力不济，所以还得请楼主详细检试，并具体描述存在问题（最好在标注不同颜色的同时再以上文字归纳问题）
昨晚回复发不出，不知什么原因。看看这次另帖发能否发出

sylun · 发表于 2022-9-7 23:50

413191246se 发表于 2022-9-7 06:59
* sylun 兄好！——没关系。我改用了前一阵重写的小宏：NumPages（但未考虑到 99 页的情况）。

谢谢413191246se关心！你那么早就上来了我就做不到了

。
我也只是业务爱好而已，基本是以问题为导向，时间久了，学得也会多些，但肯定无法跟专业的比的，比如正则，我只是入门级。
我没用过你说的函数 FindIt("China")，如果是指Function语句，我只是觉得其与Sub的区别主要是有返回值供调用它的过程使用，按理它也同样可以进行正常的设置，只要你提供给它足够的参数。
我的公共模板只有少量自编代码，基本上没有用加载项，因平时用不着，我觉得公共模板越小越好，这样运行快而稳，如果文档真要设置特定格式，应该设计专用模板，如机关公文模板。当然，专门帮别人处理不规范文档可例外。
NumToCnNum 宏只是针对性的临时使用，更新后的可转四位数以内，是参考学习网上的代码修改而成。工学习规范的代码，也可到Excel VBA版学习高手们写的代码，包括函数公式。

413191246se · 发表于 2022-9-8 08:00

* 首先，向 sylun 兄表示抱歉！我每次都要求兄台回答一个 VBA 小问题，这点很不好！我要自行百度或自己解决才是，不能给兄台找麻烦。
* 前几年跟着 duquancai 杜老师也学了学正则，但感觉杜老师说的这个“目标文本”搞不定，后来觉得，算了，还是来 VBA 吧，虽慢些但还是比较靠谱的。
* 函数和数组，我现在都是一知半解，会一点点。更高的正则、字典等知识就不会了，暂时也不想学。
* 昨晚想了，要是盲目追求模块化编程，每个宏（子过程）都不超过一屏，也太教条了。何况，比如我第一个宏：《公文自动排版 Official》，在处理字表混排时，要跳过表格处理每个表格之间的文本区域 Range，最好的办法就是对每一个区域 Range 进行统一的格式化处理。如果拆开处理，不仅代码会增多，而且速度也会下降，我现在用 Gosub gw 语句来处理，觉得挺好的，速度飞快。不少小文档都是 0.5 秒、0.6 秒左右，不超过 1 秒，就排版完毕，很不错。（不过，我爱声明单字母变量这个毛病不好改。）
* 前一段时间，我又重写了《附件 Attatchment》宏，重新捋了捋流程框架，有时间还要认真测试。
* 谢谢兄台以前为我写了不少宏，真诚感谢！唯愿兄台健康快乐每一天！

相见是缘8 · 发表于 2022-9-8 18:47

sylun 发表于 2022-9-7 23:11
更新后的代码1，请测试

sylun 老师！你让我太感动了！这么长的代码，不厌其烦的写了这么多个，真心拜谢！

可又不知怎么会事，代码在我这又运行不了，并且这次放在标准模块 “NewMacros”，或某个“模块”内，或放在“Thi sDocument”内，都反复试了，代码都运行不了，都会弹出提示框：编译错误：子过程或函数未定义。

413191246se · 发表于 2022-9-8 19:32

相见：如图中所示，“Call NumToCnNum”的意思是“呼叫”《NumToCnNum》宏，你把前一版本中的第二个小宏《NumToCnNum》复制到 sylun 老师的第 5 版本代码后面即可运行主程序了！不是什么大问题。

413191246se · 发表于 2022-9-8 19:35

相见：请将第 47 楼从 167 行至结尾的代码复制到 sylun 老师的第 5 版本代码后面即可（但是在同一个模块内不允许有相同名字的宏）。

sylun · 发表于 2022-9-8 23:16

前两晚多次尝试回复都出现问题，昨晚尝试将回复内容拆分为三帖，最后只有前两部分的帖可见，因均需审核且时间较长，无法请及时获知结果，不知什么原因。刚才多次尝试将第三部分即NumToCnNum过程单独发帖，（它可于匹配千位以内数字，但目前代码只限于百位），但均无法通过服务器。另外，刚才对昨晚发出的第120几行的一行代码作了修改（目前处于审核状态，看不到了），即将.Pattern = "[◆，、]"改为.Pattern = "[◆，]+"

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

[求助] 修改次序混乱不同的数量单位和重复的数量单位

评分