| |
参考コードを示します。
Sheet1のA列とB列を比較し、
結果をSheet2に書き出します。
標準モジュールに置いて、
main を実行します。
-------------------------------
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列の差異を調べて結果を表示する
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
'最長共通部分列に該当しない文字列を表示
ar1 = get_partition(r1.Value, dic1)
kk = 0
For Each v In ar1
If v <> "" Then
kk = kk + 1
ws2.Cells(pos + kk, 1).Value = v
End If
Next
ar2 = get_partition(r2.Value, dic2)
kk = 0
For Each v In ar2
If v <> "" Then
kk = kk + 1
ws2.Cells(pos + kk, 2).Value = v
End If
Next
'最長共通部分列に該当しない文字列に、書式を設定（赤、アンダーライン）
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
---------------------------------------------
なお、
検索で最初にヒットする、
ht tp://d.hatena.ne.jp/naoya/20090328/1238251033
を参考にさせていただきました。
|
|
γ
- 13/9/12(木) 19:52 -
