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

相见是缘8 · 发表于 2022-9-2 06:20

sylun 发表于 2022-9-1 22:58
楼主这个模拟文档也太复杂了，也许真的文档更复杂。我找时间再试试能否解决多一些问题吧，但全部解决估计 ...

好的，我能理解，sylun 老师！
你的上一个代码，至少帮我节省了一个月的时间，你多次帮我解决了超级难题，非常感谢！
老师，如你有空，我还是想恳请你再帮帮我，因像这样高难度而又复杂的问题，也只有你才有可能解决！
如实在不能全部兼容，把它们分开写几个代码也可。

zhanglei1371 · 发表于 2022-9-2 08:00

sylun 发表于 2022-9-1 22:49
实在抱歉，我之前有一段较长的时间没有登录论坛了，一来因那时较忙，二来也感觉论坛的气氛吸引力降低了。 ...

sylun大师客气了。估计您当时确实很忙

我当初的VBA入门也是背诵几个VBA的sub，其中就有一个是您写的。
让我看到了vba的强大，在此向您说声谢谢！
======================
@相见是缘8：
sylun大师基本已经将问题都解决了99%了，剩下的部分，建议可以去一个学习的好地方学习并研究下：qq群搜索群号：450360985，溢友阁。只需花一天时间就能自行解决剩余的问题。
好好学习下查找替换就行了。后续的问题不需要写vba就能解决。

相见是缘8 · 发表于 2022-9-2 08:42

zhanglei1371 发表于 2022-9-2 08:00
sylun大师客气了。估计您当时确实很忙
我当初的VBA入门也是背诵几个VBA的sub，其中就有一个是您写 ...

zhanglei1371老师好！
手动 “查找替换”，我也会一些，花一天的时间，学习 “查找替换”，就能自行解决剩余的问题？不可能吧？

zhanglei1371 · 发表于 2022-9-2 09:59

相见是缘8 发表于 2022-9-2 08:42
zhanglei1371老师好！
手动 “查找替换”，我也会一些，花一天的时间，学习 “查找替换”，就能自行解决 ...

在群友的帮助下，再看看群主的优秀视频教程，半天算长时间了。估计一个小时不到就能解决。

相见是缘8 · 发表于 2022-9-2 14:29

zhanglei1371 发表于 2022-9-2 09:59
在群友的帮助下，再看看群主的优秀视频教程，半天算长时间了。估计一个小时不到就能解决。

手动一个小时能解决，哪代码应该也不会很复杂，老师能不能，先帮忙写个代码，救下急呢？

相见是缘8 · 发表于 2022-9-4 10:30

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

sylun 老师好！
有不有办法在你该代码上，再增加一个数量单位 “升”，数量判断上，由原来的 “一二三四五六七八九十半”，增加可以判断“几百几十几、几百几十、几百几、百、十几、几十、几十几”等。
谢谢！

sylun · 发表于 2022-9-4 22:40

相见是缘8 发表于 2022-9-4 10:30
sylun 老师好！
有不有办法在你该代码上，再增加一个数量单位 “升”，数量判断上，由原来的 “一二三四 ...

这两天花了不少时间更新代码，按原思路不好弄，标点符号太复杂了，只好再变通，多了几十行，经简单测试基本上通过，小问题会有，请详细测试，最怕是有删减。可能也会出现冲突情形，如中药名最后的字是汉字数字的或本身成数量形式的，请楼主自行预处理。文档内容组合情况千变万化，如不能一次性告知，别人是无法很难每次都满足要求的，还是请楼主自行修改代码，其实有的修改是比较简单的。不清楚可以交流，应该会有人清楚的。我也不是专业人士，代码仅作学习交流之用。

Private num$(99)
Sub test4()
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)
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)
info1(3, n) = info(2, j) - info(2, j - 1) + 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) - 1
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) Then
If info(5, m) = num(k) And info(8, m) = Empty Then
info2(i) = info2(i) & info(0, m) & "、"
ElseIf info(5, m) = num(k) And info(8, m) <> Empty Then
info2(i) = info2(i) & info(0, m) & "、"
End If
End If
Next
Next
Next
For m = 1 To Len(code) '处理判断为相同数量及单位的药材
If info2(i) <> Empty Then
With RegExp2
.Global = True
.Pattern = "([^、；。]+?)◆?各?([十九八七六五四三二一半]+" & Mid(code, m, 1) & "半?)、([^、。]+?)◆?各?\2([、，。]|$)"
If InStr(info2(i), Mid(code, m, 1)) Then
Do While .test(info2(i)) = True
info2(i) = .Replace(info2(i), "$1◇$3◆各$2$4") '此处与原处理要求有所不同
Loop
.Pattern = "◇"
info2(i) = .Replace(info2(i), "、")
.Pattern = "◆"
info2(i) = .Replace(info2(i), "，")
End If
.Pattern = "(，各([十九八七六五四三二一半]+" & Mid(code, m, 1) & ")[、，；。])(.*?\2)(?=[、，；。])"
info2(i) = .Replace(info2(i), "、$3")
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) - 1
Else
.SetRange Selection.Start + data1(2, i) - 1, Selection.Start + data1(2, i) + data1(3, i) - 1
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
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-9-5 08:21

sylun 发表于 2022-9-4 22:40
这两天花了不少时间更新代码，按原思路不好弄，标点符号太复杂了，只好再变通，多了几十行，经简单测试基 ...

sylun老师好！

真是惭愧和感激！因本人实在是个外行，不能一次准确描述所有问题，导致要求多变，难为和让你受累了，实在对不住老师！自行修改代码，确实是水平不够（你的代码3，我也花了2天时间，试着修改，可以失败告终），不得不再次向你求援，我也知道这样不好，可实在是……！

该代码，我在“模拟附件”上测试了，需还有几处替换不准确，但也基本达愿，如你有时间修改一下更好，没时间就算了，实在是耗你的时间和精力太多，真是不好意思，还请你见谅！再次感谢老师！

sylun · 发表于 2022-9-6 23:49

413191246se 发表于 2022-9-1 23:03
* 论坛离不开老师呀！——因为我们都企盼着老师给予指导！（相见是缘的新问题，老师可否考虑编写一个新的 ...

* 最近，我重写了一个小宏，作用是排版完毕，显示全部页面。开始还挺好，后来，它自动变为很小的比例，大约是 10% 的显示比例吧！应该比较大才对。老师要是有时间，给看一下，怎么回事。

Sub MultiPages()
'此宏有问题！——排版完毕，多页显示时，比例非常小！尚无解决办法。（加 .PageColumns=1 也无济于事）
ActiveWindow.ActivePane.View.Zoom.PageColumns = ActiveDocument.ComputeStatistics(wdStatisticPages)
End Sub

413191246se兄好！你提到的这个现象应该你是对Zoom的相关属性进行了设置所致，我觉得，其下的Pagecolumns、Pagerows和Percentage属性值的相互影响，可试试分别重新设置常规属性值。上次忘了回复，不好意思。

413191246se · 发表于 2022-9-7 06:59

* sylun 兄好！——没关系。我改用了前一阵重写的小宏：NumPages（但未考虑到 99 页的情况）。

Sub NumPages()
'页数
Dim p&
p = ActiveDocument.ComputeStatistics(wdStatisticPages)
With ActiveWindow.ActivePane.View.Zoom
If .PageColumns = p Then .PageColumns = 3 Else .PageColumns = p
.PageRows = 1
End With
End Sub

复制代码

* 我昨天浏览你的帖子时，发现在我的 FindRange 宏中，要判断是否插入点，我用 .End，你用 .Start。经过测试，我已经用了你的这句代码：If .Start > Selection.End Then Exit Do

* 既然 sylun 兄已经被我打扰了，我再麻烦问一下，我在查找操作中，多数情况下是使用下面的代码：

Sub FindActiveDocument()
'全文查找/光标不动/不激活对象/速度极快！
With ActiveDocument.Content.Find
.ClearFormatting
.Text = "China"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.Font.Color = wdColorRed
' .Start = .End
End With
Loop
End With
End Sub

复制代码

前几天，我经过反复思考，把它改成函数 FindIt("China") 查找成功！但只能是找到，想对其设置格式（比如变红），不能在函数外面加代码，必须在该代码段内设置。这样的话，该宏变为函数意义就不大了。你给看看能否在外面加不同的过程或函数，使之适应不同要求（如：变绿，另下划线等）。不必太勉强。

* 另外，我在最近一段的 Word VBA 公文自动排版宏中，已经把我自己写的代码删除了，换上了你写的前一段的跳过表格的代码。因为你的代码经测试是我的 13 倍之快（我的是 0.91秒，你的是 0.07秒）。我没想到，Range 区域也可以作为数组元素（当然过去我也看过别人写的代码，Excel 中的单元格也是 Range）。

* 还有，你给相见是缘8 写的代码（测试文档），运行速度是 0.18 秒左右，我的是 4.3 秒，速度是我的 23 倍之快。兄真高于我万倍！（其中的 NumToCnNum 宏，颠覆我的认知！因为，我觉得在处理汉字数目时，应该是 ChnNum2Num 才对，不知兄台怎么反向处理，搞不懂。）

* 再说一点：最近，我就很纳闷，为什么像你们这些高手总爱用 ReDim 来声明数组呢？为什么不直接用 Dim 呢？昨晚，我寻思，先别学正则了，还是先学习一下数组吧！特别是这个 ReDim，每每上来就是 ReDim，实在是搞不懂为什么。经过阅读多篇关于数组的文档，才明白原来要先声明 Dim arr() 为动态数组（因为不知道数组中含有多少元素），然后，在使用的时候，再用 ReDim 来改数组大小。——看，我的 VBA 理论水平很差劲啊！——最近，我觉得我深刻认识到，我的 VBA 水平比录制宏的水平高不了多少，还得学习啊！（又看了变量声明的一些文档。另外，看到有的文档提倡编写简洁高效的代码 Easy & Clean Code，我觉得我的不少宏都是大段一段的代码，超过了好几个屏幕，这样杂乱冗余的代码，恐怕没人爱看吧！我这个模块化编程做得不好。）

*（过去我是五笔字型打字爱好者（2003-2018），经常在网络上和网友练字，打多少字都不累。）

* VBA 中的重要技巧，如：数组（一知半解，还是 loquat 老师兼朋友在我的《电子印章》宏中给我启发，才会用一点点）、函数（现在仅会一点点很简单的）、正则、字典（看到 CreateObject 字样就发懵）、递归等多种知识点都不甚了了。昨天查看兄台的帖子，有些是看不明白的。

* 最后，衷心地祝愿 sylun 兄（既是老师，又是朋友）：中秋节快乐！合家欢乐！劳逸结合，注意休息！

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

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

评分