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

413191246se · 发表于 2022-8-30 11:06

* 相见：你即使未要求截图，我也要截图了！请看：（如果再不运行，建议你重装安装完整版 Office2003）

* sylun 老师代码，建议放到标准标准 NewMacros 中，也可放在某个模块中，在 Word 2003 中运行均正常！请看下图：

* 下面是 sylun 老师代码，在 Word 2003 中运行后的处理结果，请认真查看！

413191246se · 发表于 2022-8-30 11:13

本帖最后由 413191246se 于 2022-8-30 11:15 编辑

* 相见：sylun 老师的代码就放在 Option Explicit 下面即可在 Word 2003 中正常运行！（放在单独一个模块中也可正常运行。）——如果你照着我的图片中的位置照做了，还不运行的话，请换一个 Word 2003 版本重新安装。

* 上图中，左图为新文档，是处理结果；右图为旧文档，是你的附件原稿。——上图左图为 sylun 老师的代码的处理结果。

* 如果 sylun 老师的代码，仍然不运行，建议：1、退出 Word 2003，删除默认模板重新测试；2、重新启动电脑试试；3、重新安装 Office 2003 或 2007 或 2010。

相见是缘8 · 发表于 2022-8-30 13:57

本帖最后由相见是缘8 于 2022-8-30 14:34 编辑

413191246se 发表于 2022-8-30 11:13
* 相见：sylun 老师的代码就放在 Option Explicit 下面即可在 Word 2003 中正常运行！（放在单独一个模块中 ...

感谢老师！

啊，看了老师你的截图，才知道，“Option Explicit” 这句，是放 sylun 老师代码的最上面，且在我这个古董电脑上，要把代码，放在 “Thi sDocument” 内，终于可以了！

相见是缘8 · 发表于 2022-8-30 14:18

本帖最后由相见是缘8 于 2022-8-30 14:30 编辑

sylun 发表于 2022-8-29 22:31
4楼程序基本是按楼主1楼截图所编，确实有错漏。这样的文本处理复杂，主要是多重要求，文档格式需要归纳总结 ...

sylun 老师好！
在 413191246se 老师的指教下，代码终于可以运行了！
中午简单测试了一下，目前，只发现2个不足：就是各×两、各×钱、……的“各”字前面，都少了一逗号。还有一个就是图片中所示。没有改为各一两。
等有空，我再好好测试！

413191246se · 发表于 2022-8-30 18:36

本帖最后由 413191246se 于 2022-8-31 07:50 编辑

略。。。。

sylun · 发表于 2022-8-30 22:18

相见是缘8 发表于 2022-8-30 14:18
sylun 老师好！
在 413191246se 老师的指教下，代码终于可以运行了！
中午简单测试了一下，目前，只发 ...

在原代码基础上作了修改，可再试试：

Private num(0 To 99) As String
Sub test3()
Dim i%, j%, k%, m%, n%, n1%, n2%, r%
Dim data$, code$, info$(), info1$(), info2$(), data1&(), data2$()
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 = "([用方]：|；)([^。；：]+[十九八七六五四三二一半][斤两钱分厘枚粒片])(。|，[^。；：]+?。)"
If .test(data) = False Then
MsgBox "找不到匹配，程序退出！", vbCritical
Exit Sub
End If
For Each Match In .Execute(data) '获取匹配方剂各药材配伍文本相关定位参数
ReDim Preserve data1(5, m)
With Match
data1(0, m) = .firstindex
data1(1, m) = .Length
data1(2, m) = data1(0, m) + data1(1, m)
data1(3, m) = .firstindex + Len(.submatches(0))
data1(4, m) = Len(.submatches(2))
data1(5, m) = data1(2, m) - data1(4, m) + 1
End With
m = m + 1
Next
With IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
For i = 0 To UBound(data1, 2)
If Selection.Type = wdSelectionIP Then
.SetRange data1(0, i), data1(2, i)
Else
.SetRange Selection.Start + data1(0, i), Selection.Start + data1(2, i)
End If
.HighlightColorIndex = wdYellow '在原文档突出显示匹配文本
Next
End With
For n = UBound(data1, 2) To 0 Step -1 '按倒序处理方剂药材配伍文本
With RegExp2
.Global = True
For i = 1 To Len(code)
.Pattern = "([^、：；。]+?([十九八七六五四三二一半]+)" & Mid(code, i, 1) & ")[、，。]"
ReDim info(Len(code))
If .test(Mid(data, data1(3, n), data1(1, n))) = True Then
For Each Match2 In .Execute(Mid(data, data1(3, n), data1(1, n)))
info(i - 1) = info(i - 1) & Match2.Value
ReDim Preserve info1(3, n1)
info1(0, n1) = Match2.submatches(0)
info1(1, n1) = Match2.submatches(1)
info1(2, n1) = Match2.firstindex
info1(3, n1) = Match2.firstindex + Match2.Length
n1 = n1 + 1
Next
For k = 99 To 0 Step -1 '对提取的药材以剂量大小进行排序
For j = 0 To UBound(info1, 2)
If info1(1, j) = num(k) Then
ReDim Preserve info2(n2)
info2(n2) = info1(0, j)
n2 = n2 + 1
End If
Next
Next
ReDim Preserve data2(r)
data2(r) = data2(r) & Join(info2, "、") '对匹配文本的中药材重新排序后的文本
r = r + 1
Erase info1
Erase info2
n1 = 0
n2 = 0
End If
Next
End With
For i = 1 To Len(code) '处理判断为相同数量及单位的药材
If Join(data2, "") <> Empty Then
For j = 0 To UBound(data2)
With RegExp2
.Pattern = "([^、；。]+?)◆?各?([十九八七六五四三二一半]+" & Mid(code, i, 1) & ")、([^、。]+?)◆?各?\2([、，。]|$)"
If InStr(data2(j), Mid(code, i, 1)) Then
Do While .test(data2(j)) = True
data2(j) = .Replace(data2(j), "$1◇$3◆各$2$4") '此处与原处理要求有所不同
Loop
.Pattern = "◇"
data2(j) = .Replace(data2(j), "、")
.Pattern = "◆"
data2(j) = .Replace(data2(j), "，")
End If
End With
Next
End If
Next
If Join(data2, "") <> Empty Then
data = Left(data, data1(3, n)) & "△" & Join(data2, "、") & Mid(data, data1(5, n), data1(4, n)) & "▲" & Mid(data, data1(2, n) + 1)
End If
Erase info
Erase data2
r = 0
Next
With Documents.Add(ActiveDocument.FullName).Content.Find
.Parent.Text = data '将处理结果输出到以原文档为模板的新文档
.Replacement.Highlight = True
.Execute "△*▲", MatchWildcards:=True, Replace:=wdReplaceAll
End With
End With
MsgBox "共处理了" & m & "条，处理条目见原文档标记、结果文本见新文档突出显示部分。"
End Sub
Sub NumToCnNum()
'生成百位内汉字小写数字
Const a As String = "一二三四五六七八九"
Dim i%
For i = 1 To 99
Select Case i
Case Is >= 20
If i Mod 10 > 0 Then
num(i) = Mid(a, Int(i / 10), 1) & "十" & Mid(a, i Mod 10, 1)
Else
num(i) = Mid(a, Int(i / 10), 1) & "十"
End If
Case Is > 10
num(i) = "十" & Mid(a, Int(i Mod 10), 1)
Case Is < 10
num(i) = Mid(a, i, 1)
Case Else
num(i) = "十"
End Select
Next
num(0) = "半"
End Sub

复制代码

相见是缘8 · 发表于 2022-8-31 06:25

sylun 发表于 2022-8-30 22:18
在原代码基础上作了修改，可再试试：

sylun 老师好！
你的水平真是大师级别！凡是疑难问题，只要你一出手，没有解决不了的，佩服之至！
代码在 “附件” 上，测试完美！感谢！
因这几天公司仓库盘货，比较忙，等有空我再在真正的大文档上测试。

相见是缘8 · 发表于 2022-8-31 07:45

413191246se 发表于 2022-8-30 18:36
* 相见：sylun 老师的代码，在我的笔记本电脑中，只须放在 Word 2003 中的标准模块 NewMacros 中，或其它模 ...

413191246se老师好！
在我这个古董电脑上，sylun 老师的这个代码，一定要放在该替换文挡下属的“Thi sDocument”内，才可以正常运行，放在标准模块 “NewMacros”，或某个“模块”内，反复试了，代码都运行不了，都会弹出提示框：编译错误：子过程或函数未定义。这个不知是啥原因造成的？
你建议我文档一篇、一篇地修改，不要求多，不然学不会、记不住，也没什么用。
我知道你是为我这方面的长进设想！对你和老师们的一直帮助，我心里感激！因目前帮我弟弟，整理的这6、7本电子书，文档都较大（小的有9百多页、大的有3千多页），且他要得较急（小孩子脾气），如把文档分割成小文档一篇、一篇地整理，恐怕要几个月的时间。
再说：学会、记住这东西，唉！真难！说句实话，心里想，可迫于生活的压力，又很难真正地很下心、静下心来学这个，也只能是临时抱你和老师们的佛脚！头痛医头、脚痛医脚！

另外，你的这个代码，我刚简单测试了一下，好像没有什么变化。

413191246se · 发表于 2022-8-31 07:50

本帖最后由 413191246se 于 2022-8-31 09:25 编辑

* 天呢！—— sylun 老师的第 3 版代码，处理结果百分之百正确无误！处理速度约 0.18 秒（大约在 0.15秒-0.21秒之间）！

* 我的第 3 版代码，处理结果不敢说百分之百，处理速度约 4.30 秒，差距 23 倍！

* 编程水平 sylun 老师是天！我是地！差距可谓“天壤之别”！——从今天起，我决定新建一个 sylun 文件夹，专门存放老师的代码。以前也有保存，但多数读不太懂，就没怎么重视及学习。

* 另外，现在我自感我的编程水平仅仅只比录制宏高一点点。还有，VBA 的许多重要技巧，如：数组（一知半解）、函数（一知半解）、正则、字典等，我都不懂，得向老师学习。

---------
* 相见：你好！——我之所以说让你一篇一篇地修改，不要贪多，主要是因为，我的代码运行太慢（处理结果也不敢保证百分之百正确）。今天早上，我上网看到 sylun 老师的第 3 版代码，测试之后，发现处理结果百分之百正确无误！处理速度之快是我的代码的 23 倍！（看来，我也要学习学习正则了！）
* 请将我的代码删除吧！我自己也不想保存了。既然代码能在你电脑上的本文档模块“This Document”中运行，你就用 sylun 老师的代码吧！并请你及你弟注意保存原始文档（打包后测试，WinRAR 可选择：最好 + 固实 + 测试 + 锁定，或建立一个文件夹叫“原始文档”，复制一份后放在“处理文档”文件夹中）。

413191246se · 发表于 2022-8-31 11:00

相见：我的代码应该放在 NewMacros 模块中（或单独模块），因为，对象是 ActiveDocument。但现在不用了，你还是用 sylun 老师的吧！（老师的代码是珍宝，我的代码是垃圾，我已经全部删除了。）

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

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