Option Explicit ' 原文上の1始まり文字位置。LCSの変更区間を、限定した短い共通部で結合する。 Public Function RC_Diff(ByVal news As String, ByVal olds As String) As Object Dim result As Object, newSpans As Collection, oldSpans As Collection Dim nc As Long, oc As Long, dp() As Long, i As Long, j As Long Dim nb() As Boolean, ob() As Boolean, ns As Long, os As Long Set result = RC_Dict(): Set newSpans = New Collection: Set oldSpans = New Collection result.Add "new", newSpans: result.Add "old", oldSpans result.Add "fallback", False nc = Len(news): oc = Len(olds) If news = olds Then Set RC_Diff = result: Exit Function ReDim nb(0 To nc + 1): ReDim ob(0 To oc + 1) ' 大きな入力は共通先頭/末尾を保った単一区間。原文を削らない。 If CDbl(nc + 1) * (oc + 1) > RC_MAX_DIFF_CELLS Then result("fallback") = True i = 1 Do While i <= nc And i <= oc If Mid$(news, i, 1) <> Mid$(olds, i, 1) Then Exit Do i = i + 1 Loop ns = nc: os = oc Do While ns >= i And os >= i If Mid$(news, ns, 1) <> Mid$(olds, os, 1) Then Exit Do ns = ns - 1: os = os - 1 Loop If ns >= i Then RC_AddSpan newSpans, i, ns - i + 1 If os >= i Then RC_AddSpan oldSpans, i, os - i + 1 Set RC_Diff = result: Exit Function End If ReDim dp(0 To nc + 1, 0 To oc + 1) For i = nc To 1 Step -1 For j = oc To 1 Step -1 If Mid$(news, i, 1) = Mid$(olds, j, 1) Then dp(i, j) = dp(i + 1, j + 1) + 1 ElseIf dp(i + 1, j) >= dp(i, j + 1) Then dp(i, j) = dp(i + 1, j) Else dp(i, j) = dp(i, j + 1) End If Next j Next i i = 1: j = 1 Do While i <= nc Or j <= oc If i > nc Then ob(j) = True: j = j + 1 ElseIf j > oc Then nb(i) = True: i = i + 1 ElseIf Mid$(news, i, 1) = Mid$(olds, j, 1) Then i = i + 1: j = j + 1 ElseIf dp(i + 1, j) >= dp(i, j + 1) Then nb(i) = True: i = i + 1 Else ob(j) = True: j = j + 1 End If Loop ' 対応する共通部の両端にどちらか側の差分がある場合だけ連結。 i = 1: j = 1 Do While i <= nc And j <= oc If nb(i) Then i = i + 1 ElseIf ob(j) Then j = j + 1 Else ns = i: os = j Do While i <= nc And j <= oc If nb(i) Or ob(j) Then Exit Do i = i + 1: j = j + 1 Loop If i - ns <= RC_MERGE_COMMON And ns + os > 2 And (i <= nc Or j <= oc) Then If (nb(ns - 1) Or ob(os - 1)) And (nb(i) Or ob(j)) Then If RC_CanMerge(Mid$(news, ns, i - ns)) Then If RC_ChangeWindow(nb, nc, ns, i) <= RC_MERGE_WINDOW And RC_ChangeWindow(ob, oc, os, j) <= RC_MERGE_WINDOW Then For ns = ns To i - 1: nb(ns) = True: Next ns For os = os To j - 1: ob(os) = True: Next os End If End If End If End If End If Loop RC_MasksToSpans nb, nc, newSpans RC_MasksToSpans ob, oc, oldSpans Set RC_Diff = result End Function Private Function RC_CanMerge(ByVal text As String) As Boolean Dim i As Long, ch As String RC_CanMerge = True For i = 1 To Len(text) ch = Mid$(text, i, 1) If InStr("。、，．,.！？!?;；:：()（）" & vbCr & vbTab & " 　0123456789０１２３４５６７８９", ch) > 0 Then RC_CanMerge = False: Exit Function Next i End Function Private Function RC_ChangeWindow(ByRef mask() As Boolean, ByVal length As Long, ByVal first As Long, ByVal after As Long) As Long Dim lo As Long, hi As Long lo = first: hi = after Do While lo > 1 If Not mask(lo - 1) Then Exit Do lo = lo - 1 Loop Do While hi <= length If Not mask(hi) Then Exit Do hi = hi + 1 Loop RC_ChangeWindow = hi - lo End Function Private Sub RC_MasksToSpans(ByRef mask() As Boolean, ByVal length As Long, ByVal spans As Collection) Dim i As Long, first As Long For i = 1 To length + 1 If mask(i) Then If first = 0 Then first = i ElseIf first > 0 Then RC_AddSpan spans, first, i - first: first = 0 End If Next i End Sub Public Sub RC_AddSpan(ByVal spans As Collection, ByVal first As Long, ByVal length As Long) Dim span As Object If length <= 0 Then Exit Sub Set span = RC_Dict(): span.Add "start", first: span.Add "length", length spans.Add span End Sub