| |
ありがとうございます。これで試してみます！
▼γ さん：
>最長共通部分列（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
|
|
［名前なし］
- 20/7/28(火) 12:40 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
