文字列を比較し色づけるExcelのマクロ

'
' 機　能：指定のアルゴリズムで文字列を比較し、一致文字数と操作パタンを返す
' 引　数：l     [in] 左側文字列
' 引　数：r     [in] 右側文字列
' 引　数：o     [out]出力パタン文字列 -=一致、L=左削除、R=右削除、A=両方削除
' 引　数：both  [in] アルゴリズム選択 TRUE=不一致文字両方削除、False＝左のみ削除
' 戻り値：      [out]一致する文字の数
Function compareStringLeft(l As String, r As String, ByRef o As String, Optional both As Boolean) As Integer
    'Debug.Print "l=" & l
    'Debug.Print "r=" & r
    Dim aa As String
    Dim ll As String
    
    If l = r Then                            ' 文字列全体一致か
        ret = Len(l)
        o = WorksheetFunction.Rept("-", Len(l))
    ElseIf Left(l, 1) = Left(r, 1) Then     ' 開始一文字一致か
        ret = 1 + compareStringLeft(Mid(l, 2), Mid(r, 2), aa)
        o = "-" & aa
    ElseIf l = "" Then                      ' 左側終わりか
        ret = 0
        o = WorksheetFunction.Rept("R", Len(r))
    ElseIf r = "" Then                      ' 右側終わりか
        ret = 0
        o = WorksheetFunction.Rept("L", Len(l))
    Else                                    ' どちかを捨てなければいけない
        If both Then                        ' 両方捨て指定か
            ret = compareStringLeft(Mid(l, 2), Mid(r, 2), ll, True)
            o = "A" & ll
        Else                                ' 左捨て
            p = InStr(r, Left(l, 1))
            If p = 0 Then
                ret = compareStringLeft(Mid(l, 2), r, ll)
                o = "L" & ll
            Else
            ret = compareStringLeft(l, Mid(r, p), ll)
                o = WorksheetFunction.Rept("R", p - 1) & ll
            End If
        End If
    End If
    compareStringLeft = ret
    DoEvents
End Function

'
' 機　能：最善のアルゴリズムを選んで文字列を比較し、一致文字数と操作パタンを返す
' 引　数：l     [in] 左側文字列
' 引　数：r     [in] 右側文字列
' 引　数：o     [out]出力パタン文字列 -=一致、L=左削除、R=右削除、A=両方削除
' 戻り値：      [out]一致する文字の数
Function compareString3(l As String, r As String, o As String) As Integer
    Dim ll As String
    Dim rr As String
    Dim aa As String
    Dim oo As String
    ' 左削除
    ml = compareStringLeft(l, r, ll)
    ' 右削除
    mr = compareStringLeft(r, l, rr)
    ' 両方削除
    ma = compareStringLeft(l, r, aa, True)
    ' 結果を解析
    Select Case WorksheetFunction.Max(ml, mr, ma)
        Case 0  ' 一致文字ない場合両方削除が早いから使う
            o = aa
        Case ml ' 左削除がよい場合
            ret = compareStringHelper(l, r, oo, Left(ll, 1))
            o = Left(ll, 1) & oo
        Case mr ' 右削除がよい場合
            ret = compareStringHelper(r, l, oo, Left(rr, 1))
            ' 左専用アルゴリズムだから結果の左右を逆にする
            oo = Replace(oo, "L", "T")
            oo = Replace(oo, "R", "L")
            oo = Replace(oo, "T", "R")
            rr = Replace(rr, "L", "T")
            rr = Replace(rr, "R", "L")
            rr = Replace(rr, "T", "R")
            o = Left(rr, 1) & oo
        Case ma ' 両方削除がよい場合
            ret = compareStringHelper(l, r, oo, Left(aa, 1))
            o = Left(aa, 1) & oo
    End Select
    compareString3 = ret
End Function
'
' 機　能：compareString3関数の引数変換
' 引　数：l     [in] 左側文字列
' 引　数：r     [in] 右側文字列
' 引　数：o     [out]出力パタン文字列
' 引　数：fixed [in] 変換方法指定  -=一致、L=左削除、R=右削除、A=両方削除
' 戻り値：      [out]一致する文字の数
Function compareStringHelper(l As String, r As String, ByRef o As String, fixed As String)
    Select Case fixed
        Case "-", "A"
            l = Mid(l, 2)
            r = Mid(r, 2)
        Case "L"
            l = Mid(l, 2)
        Case "R"
            r = Mid(r, 2)
        Case Else
            ' change nothing
    End Select
    compareStringHelper = compareString3(l, r, o)
End Function


'
' 機　能：隣接の両列(row)文字列を一つずつ比較し、違い部分を色づける
' 前　提：実行前にカーソルを左上のcellに
' 停　止：左の列の値がNULLになる場合
' 注　意：遅い作業である、長い文字列に慎用
' 注　意：正確性未証明、use as your own risk
Sub CompareAndMarkStrings()
    Dim oo As String
    Dim m As Integer
    ' データなくなるまで
    Do
        ' 比較
        m = compareString3(ActiveCell.Value, ActiveCell.Offset(, 1).Value, oo)
        ' 色づけ
        l = 1
        r = 1
        For i = 1 To Len(oo)
            Select Case Mid(oo, i, 1)
                Case Is = "-"
                    l = l + 1
                    r = r + 1
                Case Is = "A"
                    ActiveCell.Characters(Start:=l, Length:=1).Font.ColorIndex = 3
                    ActiveCell.Offset(, 1).Characters(Start:=r, Length:=1).Font.ColorIndex = 3
                    l = l + 1
                    r = r + 1
                Case Is = "L"
                    ActiveCell.Characters(Start:=l, Length:=1).Font.ColorIndex = 3
                    l = l + 1
                Case Is = "R"
                    ActiveCell.Offset(, 1).Characters(Start:=r, Length:=1).Font.ColorIndex = 3
                    r = r + 1
            End Select
        Next
        ' 次の行へ
        ActiveCell.Offset(1).Select
        DoEvents
    Loop Until (ActiveCell.Value = "")
    
End Sub