Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

970 / 76735

←次へ　｜　前へ→


	【81424】Re:間違いを色であらわすことはできますでしょうか？

［名前なし］ - 20/7/28(火) 12:40 -


	引用なし

	パスワード

ありがとうございます。これで試してみます！

▼γ さん：
>最長共通部分列（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

1 hits

▼

【81419】間違いを色であらわすことはできますでしょうか？ moro 20/7/26(日) 17:52