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

ttkxssry

这两天登录论坛不上来，chrome和edge都试了，都不行，刚刚用IE才能登录上来。万分感谢以上好心人的出手帮助，万分感谢！
我试试答案，然后回来回复啊！

ttkxssry

opiona 发表于 2018-3-11 12:58
根据指正，进行了修改
完整代码见附件：

多谢opiona，辛苦您了！非常抱歉，我在非常偏僻的地方，网络非常不好，经常登录不上来。
我试了一下，发现运行后， 后4行 的结果都有问题，与我上传的原excel结果不一致。可否辛苦您看一下？

我的思路是：
在查某个字的韵脚时，是寻找它与本诗词其它结尾字是否同时出现在某一韵脚中，是“同时查找”，不是单字查找。以免重复韵脚的问题。

例如：倒 这个字，有不同的韵脚，有重复性现象，B18、B19都有。

但是，在一首诗词中，与它属同一韵脚的字如果也同时出现在本诗某句的句尾(句中和句首都不考虑在内)，例如“老”字出现在本诗某句的句尾，那么就可以判定“倒”的位置，只能在B19单元格(对应代号是★18)，而不是B18单元格。同时，也确定了“老”的对应的代号也是★18，而不是别的代号

另外，在您的程序中，没看到对判断句子的符号如？。，：；、！的界定。判断句子的标准：以？。，：；、！为标准，这几个符号任意一个出现，即为一句话。


再次感谢您的帮助，铭记在心！

aman1516

ttkxssry 发表于 2018-3-14 10:57
多谢opiona，辛苦您了！非常抱歉，我在非常偏僻的地方，网络非常不好，经常登录不上来。
我试了一下，发 ...

看了解释，才终于明白一楼贴图的意思，既要按字，又要按句，还要按整首诗来判断，蛮复杂的，思维不够用了，帮你顶下

ttkxssry

aman1516 发表于 2018-3-14 16:14
看了解释，才终于明白一楼贴图的意思，既要按字，又要按句，还要按整首诗来判断，蛮复杂的，思维不够用了 ...

再举例以帮助理解。
例如：你这个人，既是篮球协会的，又是足球协会的，又是作家协会的。
而我呢，既是纺织协会的，又是佛教协会的，也是作家协会的。
如果我和你同时出现在一起，这时判断你我的协会，那么，结果只能是共同那人协会是答案：作家协会。而不是篮球协会或佛教协会。

用同样的道理去求解诗词的韵脚，是同样的道理。即使出现同一字分属不同韵脚，也不会出现混乱，因为别的字限制了这个字是属于哪个韵脚。

ttkxssry

例如：一些人
数学兴趣组有：A、B、C、D、E、F
语言兴趣组有：G、H、I、J、D

现在某个屋里同时出现 H、K、M、P、D，则可判断D是归属语言兴趣组，同时也可判断出H。

至于本屋中K、M、P，如果相互间也有共同组，则可依据相关判定，如果没有共同组，则用“●”来替换它。

一把小刀闯天下

'前2行差不多，你确定后面的示例是正确的吗？
Option Explicit

Sub test()
  Dim i, j, k, arr, brr, crr, mark, t, tt, ttt, a, s, temp
  s = "？。，：；、"
  mark = Split("？ 。 ， ： ； 、 ！")
  With Sheets("韵脚")
    crr = .Range("a2:b" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  With Sheets("问题")
    arr = .Range("a2:a" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  For i = 1 To UBound(arr, 1)
    temp = arr(i, 1)
    For j = 0 To UBound(mark)
      arr(i, 1) = Replace(arr(i, 1), mark(j), "|")
    Next
    t = Split(Replace(arr(i, 1), Space(1), vbNullString), "|")
    ReDim tt(UBound(t), 1), ttt(UBound(t))
    For j = 0 To UBound(t) - 1
      a = Right(t(j), 1)
      For k = 1 To UBound(crr, 1)
        If InStr(crr(k, 2), a) Then
          tt(j, 0) = a: tt(j, 1) = k
          Exit For
        End If
    Next k, j
    For j = 0 To UBound(tt)
      For k = 0 To UBound(tt)
        If k <> j Then
          If tt(j, 1) = tt(k, 1) Then ttt(j) = 1: Exit For
        End If
    Next k, j
    For j = 0 To UBound(t) - 1
      If ttt(j) = 1 Then
        t(j) = Left(t(j), Len(t(j)) - 1) & crr(tt(j, 1), 1)
      Else
        t(j) = Left(t(j), Len(t(j)) - 1) & "●"
      End If
    Next
    tt = vbNullString
    For j = 1 To Len(temp) - 1
      If InStr(s, Mid(temp, j, 1)) Then
        tt = tt & Mid(temp, j, 1)
      End If
    Next
    For j = 0 To UBound(t)
      t(j) = t(j) & Mid(tt, j + 1, 1)
    Next
    arr(i, 1) = Join(t, vbNullString) & "。"
  Next
  Sheets("问题").[c2].Resize(UBound(arr, 1), 1) = arr
End Sub

一把小刀闯天下

'分付还他了。 怎么理解？
'最后一个字全匹配也跟你示例不一样
Option Explicit

Sub test()
  Dim i, j, k, arr, brr, crr, mark, t, tt, ttt, a, s, temp, dic
  Set dic = CreateObject("scripting.dictionary")
  s = "？。，：；、"
  mark = Split("？ 。 ， ： ； 、 ！")
  With Sheets("韵脚")
    crr = .Range("a2:b" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  With Sheets("问题")
    arr = .Range("a2:a" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  For i = 1 To UBound(arr, 1)
    temp = arr(i, 1)
    For j = 0 To UBound(mark)
      arr(i, 1) = Replace(arr(i, 1), mark(j), "|")
    Next
    t = Split(Replace(arr(i, 1), Space(1), vbNullString), "|")
    For j = 0 To UBound(t) - 1
      a = Right(t(j), 1)
      dic(a) = dic(a) + 1
    Next
    arr(i, 1) = temp
  Next
  For i = 1 To UBound(arr, 1)
    temp = arr(i, 1)
    For j = 0 To UBound(mark)
      arr(i, 1) = Replace(arr(i, 1), mark(j), "|")
    Next
    t = Split(Replace(arr(i, 1), Space(1), vbNullString), "|")
    ReDim tt(UBound(t), 1), ttt(UBound(t))
    For j = 0 To UBound(t) - 1
      a = Right(t(j), 1)
      For k = 1 To UBound(crr, 1)
        If InStr(crr(k, 2), a) Then
          tt(j, 0) = a: tt(j, 1) = k
          Exit For
        End If
    Next k, j
    For j = 0 To UBound(tt)
      For k = 0 To UBound(tt)
        If k <> j Then
          If tt(j, 1) = tt(k, 1) Then ttt(j) = 1: Exit For
        End If
    Next k, j
    For j = 0 To UBound(t) - 1
      If ttt(j) = 1 Or dic(tt(j, 0)) > 1 Then
        t(j) = Left(t(j), Len(t(j)) - 1) & crr(tt(j, 1), 1)
      Else
        t(j) = Left(t(j), Len(t(j)) - 1) & "●"
      End If
    Next
    tt = vbNullString
    For j = 1 To Len(temp) - 1
      If InStr(s, Mid(temp, j, 1)) Then
        tt = tt & Mid(temp, j, 1)
      End If
    Next
    For j = 0 To UBound(t)
      t(j) = t(j) & Mid(tt, j + 1, 1)
    Next
    arr(i, 1) = Join(t, vbNullString) & "。"
  Next
  Sheets("问题").[c2].Resize(UBound(arr, 1), 1) = arr
End Sub

ttkxssry

一把小刀闯天下 发表于 2018-3-14 22:59
'分付还他了。 怎么理解？
'最后一个字全匹配也跟你示例不一样
Option Explicit

非常感谢小刀出手！

检查了一下，不知道错在哪里。
而且发现最后那首诗词，不仅”了“是错的，而且发现”倒“也是错的。

我们可以用逻辑来推理一次。
运行结果中，★肯定应该是一个以上，否则结果就是错的。
理由是：判断一个字，如果和其它结尾字 经过同时搜索 ，发现在同一韵脚，这时用对应的共同韵脚来替换这个字，例如最后首诗词中，”老“和”倒“在”韵脚“表中在同一单元格B19中，则用对应的★18来替换诗词中这两字。这样，就会有至少有两个★18出现在诗词中。

如果用一句话来表达上述意思，那就是：
如果★18出现，那么就必然应该超过2个。否则如果只是一个★18就是错误的。因为逻辑上，如果这个字没和其它结尾字在同一韵脚，那么应该用●来替换才对。

我再继续学习一下您的代码，非常感谢！

ttkxssry

问题还没是没有解决，还要顶一下，以盼能得到解决。

zopey

如果不考虑古代、现代读音的变化， 寻找相同韵脚不应该从汉字转拼音，开始分析吗