寻找相同韵脚的结尾字(一个比较抽象而有意义的古典诗词问题)

ttkxssry

大家早上好。在这里请教一个问题，是我在研究古典诗词规律时遇到的。对您的帮助，本人非常感激！ 详细说明和例子见附件，供试验。

背景介绍：
“问题”表有两列，A列是原句，B列是目标列，即：欲达到的结果放在B列。
“韵脚”表有两列，B列是各个字，A列是各字对应的韵脚代码。

目的：
针对单元格内每句话最后一个字，在“韵脚”表中搜索，如果结尾字与结尾字相互在同一单元格，则用该字所对应的韵脚代码去替换该字。如果该字与其它结尾字都不在同一单元格内，则用●替换该字。

备注：判断句子的标准：以？。，：；、！为标准，只要这几个符号任意一个出现，即为一句话。


例如A2单元格，每句话最后的字分别是“草，草，老，晴，明，月，月，绝”，在“韵脚”表中搜索发现：
“草老”都在同一单元格内，对应的代码是★18，则用代码★18替换“草老”。
“晴明”在同一单元格内，对应代码是★9，则用代码★9替换“晴明”。
“月”和“月”是同一个字，对应的代码是★105，则用代码★105替换这两个月字。
“绝”则与任何结尾字都不在同一单元格，则用符号●替换绝。         最后完成的结果则放在B2内。

再举一例：A9单元格内各句最后字分别是“舟，老，沼，了，空，鸟，倒，少，晓”，在韵脚表中搜索发现：
“老倒”在同一单元格内，对应的代码是★18，则用★18替换“老倒”。
“沼了鸟少晓”在同一单元格内，对应的代码是★80，则用代码★80替换“沼了鸟少晓”。
“舟空”与任何结尾字都不在同一单元格中，则用符号●替换这两字。         最后完成的结果放在B9内。

ttkxssry

题目比较难？我再顶一下。

opiona

按照提示，在10楼进行了更新

1. Sub opiona()
   
2.    
   
3.     Set SH1 = Worksheets("问题")
   
4.     Set SH2 = Worksheets("韵脚")
   
5.    
   
6.     Rem 全部韵脚和汉字放入数组
   
7.     ARR_YUNJIAO = SH2.Range("A2:B" & SH2.Range("A65536").End(3).Row).Value
   
8.    
   
9.     For IROW = 2 To SH1.Range("A65536").End(3).Row
   
10.         Rem 按照标点符号拆分
    
11.         ARX = Split(GetRegStr(SH1.Cells(IROW, 1).Value, "[一-龥]+[^0-9A-Za-z一-龥 ]", 0), "|")
    
12.         Rem  寻找韵脚汉字
    
13.         For X = 0 To UBound(ARX)
    
14.             StrA = Mid(ARX(X), Len(ARX(X)) - 1, 1)  '//包括标点符号的倒数第二个
    
15.             StrB = "●" '假设找不到
    
16.             Rem 查找汉字对应的韵脚
    
17.             For I = 1 To UBound(ARR_YUNJIAO, 1)
    
18.                 If InStr(ARR_YUNJIAO(I, 2), StrA) > 0 Then
    
19.                     Rem 记录此韵脚
    
20.                     StrB = ARR_YUNJIAO(I, 1)
    
21.                     Exit For
    
22.                 End If
    
23.             Next
    
24.             Rem 用韵脚符号替换韵脚汉字
    
25.             ARX(X) = Mid(ARX(X), 1, Len(ARX(X)) - 2) & Replace(Mid(ARX(X), Len(ARX(X)) - 1, 1), StrA, StrB) & Mid(ARX(X), Len(ARX(X)), 1)
    
26.         Next
    
27.         
    
28.         Rem 将拆分后的数组，还原为字符串
    
29.         SH1.Cells(IROW, 2).Value = Join(ARX, "")
    
30.         
    
31.         Rem 标注韵脚符号的颜色
    
32.         BRX = Split(GetRegStr(SH1.Cells(IROW, 2).Value, "[●|★][0-9]+", 0), "|")
    
33.         StratInt = 1
    
34.         For X = 0 To UBound(BRX)
    
35.             INTLEN = InStr(StratInt, SH1.Cells(IROW, 2).Value, BRX(X))
    
36.             SH1.Cells(IROW, 2).Characters(Start:=INTLEN, Length:=Len(BRX(X))).Font.Color = -16776961
    
37.             StratInt = INTLEN + Len(BRX(X))
    
38.         Next
    
39.         
    
40.     Next
    
41.    
    
42. End Sub

复制代码

opiona

按照提示，在10楼进行了更新

正则方式判断的
完整代码见附件： 寻找相同韵脚.rar (30.5 KB, 下载次数: 9)

2018-3-10 18:19 上传

点击文件名下载附件

aman1516

ttkxssry 发表于 2018-3-10 12:36
题目比较难？我再顶一下。

试试：

1. 
   
2. Sub ShengYun()
   
3. Dim brr, bd, r1, r2, ij, k, b, f As Boolean
   
4. bd = "，,。.、；;：:！!"
   
5. With Sheets("韵脚")
   
6.      r2 = .[A65536].End(xlUp).Row
   
7.      brr = .Range("A1:B" & r2).Value
   
8. End With
   
9. With Sheets("问题")
   
10.      r1 = .[A65536].End(xlUp).Row
    
11.      .Range("B2:B" & r1).ClearContents
    
12.      For i = 2 To r1
    
13.          .Cells(i, 2) = .Cells(i, 1)
    
14.          j = 1
    
15.          Do
    
16.              If InStr(bd, Mid(.Cells(i, 2), j, 1)) Then
    
17.                 f = False
    
18.                 For k = 2 To UBound(brr)
    
19.                     If InStr(brr(k, 2), Mid(.Cells(i, 2), j - 1, 1)) Then
    
20.                        .Cells(i, 2).Characters(j - 1, 1).Text = brr(k, 1)
    
21.                        j = j + Len(brr(k, 1))
    
22.                        f = True
    
23.                        Exit For
    
24.                     End If
    
25.                 Next
    
26.                 If f = False Then
    
27.                     .Cells(i, 2).Characters(j - 1, 1).Text = "●"
    
28.                 End If
    
29.              End If
    
30.              j = j + 1
    
31.              p = Len(.Cells(i, 2))
    
32.              If j > p Then Exit Do
    
33.          Loop
    
34.      Next
    
35. End With
    
36. End Sub

复制代码

aman1516

见附件：
寻找相同韵脚的结尾字-1.rar (31.56 KB, 下载次数: 3)

2018-3-10 19:49 上传

点击文件名下载附件

蓝桥玄霜

同一个字有几个不同的韵脚，还是会有不确定的。
比如“”倒“”，B18、B19都有，怎么确定是哪一个？

aman1516

学习下正则：

1. Sub ShengYun2()
   
2. Dim RegEx1, RegEx2, arr, brr, r1, r2, i, j, a, b, c, d, sr, st, s, f As Boolean
   
3. Set RegEx1 = CreateObject("VBSCRIPT.REGEXP")
   
4. Set RegEx2 = CreateObject("VBSCRIPT.REGEXP")
   
5. On Error Resume Next
   
6. Application.ScreenUpdating = False
   
7. RegEx1.Global = True
   
8. RegEx1.IgnoreCase = True
   
9. RegEx1.Pattern = "[!-~]"
   
10. RegEx2.Global = True
    
11. RegEx2.IgnoreCase = True
    
12. RegEx2.Pattern = "[\？|、|！|，|。|【}】]"
    
13. With Sheets("韵脚")
    
14.      r2 = .[A65536].End(xlUp).Row
    
15.      brr = .Range("A1:B" & r2).Value
    
16. End With
    
17. With Sheets("问题")
    
18.      r1 = .[A65536].End(xlUp).Row
    
19.      .Range("B2:B" & r1).ClearContents
    
20.      arr = .Range("A1:B" & r1).Value
    
21.      For i = 2 To UBound(arr)
    
22.          a = arr(i, 1)
    
23.          b = RegEx1.Replace(a, "*")
    
24.          c = Replace(b, "*", "")
    
25.          d = RegEx2.Replace(c, "|")
    
26.          sr = Split(d, "|")
    
27.          Set st = RegEx2.Execute(a)
    
28.          For s = 0 To UBound(sr)
    
29.              f = False
    
30.              For j = 2 To UBound(brr)
    
31.                  If InStr(brr(j, 2), Right(sr(s), 1)) Then
    
32.                     sr(s) = Left(sr(s), Len(sr(s)) - 1) & brr(j, 1) & st(s)
    
33.                     f = True
    
34.                  End If
    
35.              Next
    
36.              If f = False Then
    
37.                 sr(s) = Left(sr(s), Len(sr(s)) - 1) & "●" & st(s)
    
38.              End If
    
39.          Next
    
40.          arr(i, 2) = Join(sr, "")
    
41.      Next
    
42.      .Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
43. End With
    
44. Erase arr, brr
    
45. Set RegEx1 = Nothing
    
46. Set RegEx2 = Nothing
    
47. Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

aman1516

将颜色也设置下，见附件：

opiona

根据指正，进行了修改
完整代码见附件： 寻找相同韵脚.rar (31.54 KB, 下载次数: 6)

2018-3-11 12:59 上传

点击文件名下载附件

多次出现的韵脚，显示数字
只出现一次的，用圆圈替换

1. Sub opiona()
   
2.    
   
3.     Set SH1 = Worksheets("问题")
   
4.     Set SH2 = Worksheets("韵脚")
   
5.    
   
6.     Rem 全部韵脚和汉字放入数组
   
7.     ARR_YUNJIAO = SH2.Range("A2:B" & SH2.Range("A65536").End(3).Row).Value
   
8.    
   
9.     For IROW = 2 To SH1.Range("A65536").End(3).Row
   
10.         Rem 按照标点符号拆分
    
11.         ARX = Split(GetRegStr(SH1.Cells(IROW, 1).Value, "[一-龥]+[^0-9A-Za-z一-龥 ]", 0), "|")
    
12.         
    
13.         Rem  寻找全部韵脚汉字
    
14.         ReDim CRX(0)
    
15.         CLEN = 0
    
16.         For X = 0 To UBound(ARX)
    
17.             StrA = Mid(ARX(X), Len(ARX(X)) - 1, 1)  '//包括标点符号的倒数第二个
    
18.             For I = 1 To UBound(ARR_YUNJIAO, 1)
    
19.                 If InStr(ARR_YUNJIAO(I, 2), StrA) > 0 Then
    
20.                     Rem 记录此韵脚
    
21.                     ReDim Preserve CRX(CLEN)
    
22.                     CRX(CLEN) = ARR_YUNJIAO(I, 1)
    
23.                     CLEN = CLEN + 1
    
24.                     Exit For
    
25.                 End If
    
26.             Next
    
27.         Next
    
28.         
    
29.         For X = 0 To UBound(ARX)
    
30.             StrA = Mid(ARX(X), Len(ARX(X)) - 1, 1)  '//包括标点符号的倒数第二个
    
31.             Rem 查找汉字对应的韵脚
    
32.             XX = 0
    
33.             For I = 1 To UBound(ARR_YUNJIAO, 1)
    
34.                 If InStr(ARR_YUNJIAO(I, 2), StrA) > 0 Then
    
35.                     Rem 记录此韵脚
    
36.                     StrB = ARR_YUNJIAO(I, 1)
    
37.                     For Z = 0 To UBound(CRX)
    
38.                         If StrB = CRX(Z) Then
    
39.                             XX = XX + 1  '//记录此韵脚出现的次数
    
40.                         End If
    
41.                     Next
    
42.                     Exit For
    
43.                 End If
    
44.             Next
    
45.             Rem 2个及以上则用韵脚符号替换韵脚汉字
    
46.             If XX > 1 Then
    
47.                 ARX(X) = Mid(ARX(X), 1, Len(ARX(X)) - 2) & Replace(Mid(ARX(X), Len(ARX(X)) - 1, 1), StrA, StrB) & Mid(ARX(X), Len(ARX(X)), 1)
    
48.             Else
    
49.                 Rem 只有一个 则是：●
    
50.                 ARX(X) = Mid(ARX(X), 1, Len(ARX(X)) - 2) & Replace(Mid(ARX(X), Len(ARX(X)) - 1, 1), StrA, "●") & Mid(ARX(X), Len(ARX(X)), 1)
    
51.             End If
    
52.         Next
    
53.         
    
54.         Rem 将拆分后的数组，还原为字符串
    
55.         SH1.Cells(IROW, 2).Value = Join(ARX, "")
    
56.         
    
57.         Rem 标注韵脚符号的颜色
    
58.         BRX = Split(GetRegStr(SH1.Cells(IROW, 2).Value, "[★][0-9]+", 0), "|")
    
59.         StratInt = 1
    
60.         For X = 0 To UBound(BRX)
    
61.             INTLEN = InStr(StratInt, SH1.Cells(IROW, 2).Value, BRX(X))
    
62.             SH1.Cells(IROW, 2).Characters(Start:=INTLEN, Length:=Len(BRX(X))).Font.Color = -16776961
    
63.             StratInt = INTLEN + Len(BRX(X))
    
64.         Next
    
65.         
    
66.     Next
    
67.    
    
68. End Sub

复制代码