| |
最長共通部分列（longest common subsequence)問題という
比較的良く知られた問題らしいです。
（文章の差異を表示するDiffコマンドというものも同じアルゴリズムの系列です。）
大昔、こちらの掲示板に投稿したものの一部を修正（表示の一部を削除）したものです。
参考にしてください。
Sheet1のA列とB列を比較した結果を、
Sheet2のA列とB列に表示します。（不一致箇所を赤文字かつアンダーラインで表示）
Option Explicit
Dim lcs() As Long
Dim dic1 As Object
Dim dic2 As Object
Dim s1 As String
Dim s2 As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Sub main()
Dim k As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
'書き込み先のシートをクリアー
ws2.UsedRange.Clear
'A列とB列の差異を調べて結果をSheet2に表示する
For k = 1 To ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row
diff ws1.Cells(k, 1), ws1.Cells(k, 2)
Next
End Sub
Sub diff(r1 As Range, r2 As Range)
Dim ar1, ar2
Dim v
Dim pos As Long
Dim kk As Long
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
' 二つの文字列のLCSの長さを求める
get_lcs r1, r2
'それに対応する最長共通部分列を求める
get_lcs_string r1.Value, r2.Value
'結果をSheet2に書き込む
pos = Application.Max(ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row, _
ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row) _
+ 1
ws2.Cells(pos, 1) = s1
ws2.Cells(pos, 2) = s2
'最長共通部分列に該当しない文字列に、書式を設定（赤、アンダーライン）
setColor ws2.Cells(pos, 1), ws2.Cells(pos, 2)
End Sub
Function get_lcs(r1 As Range, r2 As Range)
Dim j As Long, k As Long
s1 = r1.Value
s2 = r2.Value
' lcs(j,k) は s1の1からjまでの部分列と
' s2の1からkまでの部分列との
' LCSの長さを示す
ReDim lcs(0 To Len(s1), 0 To Len(s2))
For j = 1 To Len(s1)
For k = 1 To Len(s2)
If Mid(s1, j, 1) = Mid(s2, k, 1) Then
lcs(j, k) = lcs(j - 1, k - 1) + 1
Else
lcs(j, k) = WorksheetFunction.Max(lcs(j, k - 1), lcs(j - 1, k))
End If
Next
Next
End Function
Function get_lcs_string(s1 As String, s2 As String)
get_lcs_string_sub Len(s1), Len(s2)
End Function
Function get_lcs_string_sub(j As Long, k As Long)
If j = 0 Or k = 0 Then Exit Function
If Mid(s1, j, 1) = Mid(s2, k, 1) Then
Call get_lcs_string_sub(j - 1, k - 1)
dic1(j) = Empty 's1 の j番目の文字がLCSを構成
dic2(k) = Empty 's2 の k番目の文字がLCSを構成
Else
If lcs(j - 1, k) >= lcs(j, k - 1) Then
Call get_lcs_string_sub(j - 1, k)
Else
Call get_lcs_string_sub(j, k - 1)
End If
End If
End Function
Function get_partition(s As String, d As Object) As Variant
Dim key
For Each key In d.keys
Mid$(s, key, 1) = "_" ' 余り使用されない文字の意
Next
get_partition = Split(s, "_")
End Function
Function setColor(r1 As Range, r2 As Range)
Dim j As Long, k As Long
'背景色を水色
r1.Interior.ColorIndex = 34
r2.Interior.ColorIndex = 34
'マッチしない文字列の文字色を赤に
For j = 1 To Len(r1.Value)
If Not dic1.exists(j) Then
With r1.Characters(Start:=j, Length:=1).Font
.Underline = xlUnderlineStyleSingle
.ColorIndex = 3
End With
End If
Next
For k = 1 To Len(r2.Value)
If Not dic2.exists(k) Then
With r2.Characters(Start:=k, Length:=1).Font
.Underline = xlUnderlineStyleSingle
.ColorIndex = 3
End With
End If
Next
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
