Oscar Sun

                  Sub 詞學韻字相似度比對()
rt = Sheets(1).UsedRange.Rows.Count
cou = 1
For i = 2 To rt
    X = Sheets(1).Cells(i, "j") '韻字欄位
    If X = "" Then MsgBox "韻字欄位無資料!!", vbExclamation: GoTo N
    xL = Len(X)
    For j = i + 1 To rt
        y = Sheets(1).Cells(j, "j")
        yL = Len(y)
        If Abs(yL - xL) / xL <= 1 / 2 Then '字串長度不能差太多
            For Z = 1 To xL
                If InStr(1, y, Mid(X, Z, 1), vbTextCompare) > 0 Then
                'If StrComp(Mid(x, z, 1), Mid(y, z, 1), vbTextCompare) = 0 Then
                    samecount = samecount + 1
                End If
            Next Z
            If samecount / xL > 0.5 Then
                If cou = Sheets(2).Rows.Count Then MsgBox "筆數太多,超出Excel工作表的上限了...", vbExclamation: End
                cou = cou + 1
                Sheets(2).Cells(cou, 1) = Sheets(1).Cells(i, "a") 'ID或序號-取以比對詞作
                Sheets(2).Cells(cou, 2) = Sheets(1).Cells(j, "a") 'ID或序號-被比對詞作
                Sheets(2).Cells(cou, 3) = Sheets(1).Cells(i, "f") '首句-取以比對詞作
                Sheets(2).Cells(cou, 4) = Sheets(1).Cells(j, "f") '首句-被比對詞作
                Sheets(2).Cells(cou, 5) = Sheets(1).Cells(i, "j") '韻字-取以比對詞作
                Sheets(2).Cells(cou, 6) = Sheets(1).Cells(j, "j") '韻字-被比對詞作
                '會有一對多的關係
'                If Cells(i, "n") = "" Then
'                    Cells(j, "n") = Cells(i, "o")
'                Else
'                    Stop
'                    Cells(j, "p") = Cells(i, "o")
'
'                End If
            End If
        End If
        samecount = 0
    Next j
N:
Next i
End Sub