Excel マクロが急に誤作動するようになった

Question

これまで正常に作動していた差分チェックマクロが急に誤作動するようになり、原因が分からなくて
困っています。

＜マクロの内容＞
新旧2つの故障コードリストがあり、ワークシート1に新しいリスト、ワークシート2に古いリストが
記載されています。2つのリストの行数は同じではなく、新規コードの追加、既存原文の変更、既存
訳文の変更の可能性があります。

リストの構成
A列：コード、B列：原文、C列：訳文

1. C列の訳文を比較し、差分（新出/変更）があれば、D列に「New」と表記

　 データ数が多いので、配列を使用

1. A列の訳文を比較し、差分があれば、コードを赤字に変更

2. B列の原文を比較し、差分があれば、原文を青字に変更

3. タイトル行を固定

実際のリストが公開できないため難しいかもしれませんが、誤作動を誘発している可能性のあるコードが
分かれば修正できるかもしれないので、それだけでも助かります。
また、誤作動の内容ですが、新出や変更でないものまで、Newとなったり、赤字/青字になったりする
ようになりました。ちなみに、今回、リストの全体的な修正があったため、どこかに誤作動の原因になる
変更があった可能性もありますが、基本的にリストの形式は同じです。

＜実際のコード＞
Sub KDVDB_DiffCheck()
Dim strProm As String
Dim ws1, ws2 As Worksheet

 Set ws1 = Worksheets("New")
 Set ws2 = Worksheets("Old")
 
 Application.ScreenUpdating = False

 strProm = NoMtch(ws1.Cells(1, 3), ws2.Cells(1, 3))
         
 Call CheckCode
 Call CheckSource
 Call Freeze_row
 
 Application.ScreenUpdating = True
 
 MsgBox "差分チェックの結果はシート『New』に表示されます。", Title:="処理完了", Buttons:=vbInformation

End Sub

Private Function NoMtch(ws1 As Range, ws2 As Range) As String

 Dim i As Long
 Dim lngRows As Long
 Dim vntData() As Variant
 Dim dicIndex As Object

 Set dicIndex = CreateObject("Scripting.Dictionary")

 With ws2
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtch = "データがありません"
         GoTo Wayout
     End If
     vntData = .Offset(1).Resize(lngRows + 1).Value
 End With

 For i = 1 To lngRows
     dicIndex.Item(vntData(i, 1)) = Empty
 Next i

 With ws1
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtch = "データがありません"
         GoTo Wayout
     End If

     With .Offset(1).Resize(lngRows + 1)
         vntData = .Value
     End With
 End With

 For i = 1 To lngRows
     If Not dicIndex.Exists(vntData(i, 1)) Then
         With ws1.Offset(i)
             ws1.Offset(i, 1).Value = "New"
         End With
     End If
 Next i

Wayout:

 Set dicIndex = Nothing

End Function

Sub CheckCode()
Dim strProm As String
Dim ws1, ws2 As Worksheet

 Set ws1 = Worksheets("New")
 Set ws2 = Worksheets("Old")
 
 strProm = NoMtchC(ws1.Cells(1, 1), ws2.Cells(1, 1))
 

End Sub

Function NoMtchC(ws1 As Range, ws2 As Range) As String

 Dim i As Long
 Dim lngRows As Long
 Dim vntData() As Variant
 Dim dicIndex As Object

 Set dicIndex = CreateObject("Scripting.Dictionary")

 With ws2
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtchC = "データがありません"
         GoTo Wayout
     End If
     vntData = .Offset(1).Resize(lngRows + 1).Value
 End With

 For i = 1 To lngRows
     dicIndex.Item(vntData(i, 1)) = Empty
 Next i

 With ws1
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtchC = "データがありません"
         GoTo Wayout
     End If

     With .Offset(1).Resize(lngRows + 1)
         vntData = .Value
     End With
 End With

 For i = 1 To lngRows
     If Not dicIndex.Exists(vntData(i, 1)) Then
         With ws1.Offset(i)
         .Font.Color = vbRed
         End With
     End If
 Next i

Wayout:

 Set dicIndex = Nothing

End Function

Sub CheckSource()
Dim strProm As String
Dim ws1, ws2 As Worksheet

 Set ws1 = Worksheets("New")
 Set ws2 = Worksheets("Old")
 
 strProm = NoMtchS(ws1.Cells(1, 2), ws2.Cells(1, 2))

End Sub

Function NoMtchS(ws1 As Range, ws2 As Range) As String

 Dim i As Long
 Dim lngRows As Long
 Dim vntData() As Variant
 Dim dicIndex As Object

 Set dicIndex = CreateObject("Scripting.Dictionary")

 With ws2
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtchS = "データがありません"
         GoTo Wayout
     End If
     vntData = .Offset(1).Resize(lngRows + 1).Value
 End With

 For i = 1 To lngRows
     dicIndex.Item(vntData(i, 1)) = Empty
 Next i

 With ws1
     lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
     If lngRows <= 0 Then
         NoMtchS = "データがありません"
         GoTo Wayout
     End If

     With .Offset(1).Resize(lngRows + 1)
         vntData = .Value
     End With
 End With

 For i = 1 To lngRows
     If Not dicIndex.Exists(vntData(i, 1)) Then
         With ws1.Offset(i)
         .Font.Color = vbBlue
         End With
     End If
 Next i

Wayout:

 Set dicIndex = Nothing

End Function

Sub Freeze_row()

Worksheets("New").Activate
Rows(2).Select
ActiveWindow.FreezePanes = True
Range("A1").Select

End Sub

以上、よろしくお願いいたします。

＜解決しました＞

誤動作の原因が分かりました。
どう見ても同じなのに不一致、つまり差分箇所と判定されている箇所を
抜き出し、LEN関数で文字数を確認したところ、1文字違っていました。
一方のリストに余分な制御コードが含まれていたのです。
セル内の改行回数は同じであり、スペースもないので、その制御コードに
どのような機能があるのかは不明ですが、すべてのセルの制御コードを
削除した後、改めて差分チェックマクロを実行すると、正確な結果が得られました。

今後は、制御コードによる文字数の不一致にも対応できるようにコードを書き換えたいと
思います。ただし、

　Private Sub trim()
Dim c As Range
For Each c In Selection
c = WorksheetFunction.Clean(c)
Next c
End Sub

のような簡易なコードでは時間が結構かかったので、これを何とかしなくてはいけませんが。

回答、コメントをくださった方々、ありがとうございました。

Answer 1

重複まとめると、、これでよいのかな？

Sub KDVDB_DiffCheck2()
Dim ret As String
ret = ""
Call CheckSource2(ret)
If ret <> "" Then MsgBox ret
End Sub

Sub CheckSource2(ret As String)
Dim strProm As String
Dim ws1 As Range, ws2 As Range
Set ws1 = Worksheets("New").Cells(1, 1)
Set ws2 = Worksheets("Old").Cells(1, 1)

Application.ScreenUpdating = False

Dim i As Long, j As Long
Dim lngRows As Long
Dim vntData() As Variant
Dim dicIndex As Object

Set dicIndex = CreateObject("Scripting.Dictionary")

With ws2
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - ws2.Row
    If lngRows <= 0 Then
        ret = "WS2データがありません"
        Exit Sub
    End If
    vntData = .Offset(1).Resize(lngRows + 1).Value
End With

For i = 1 To lngRows
    dicIndex.Item(vntData(i, 1)) = i
Next i

With ws1
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
        ret = "WS1データがありません"
        Exit Sub
    End If

    With .Offset(1).Resize(lngRows + 1)
        vntData = .Value
    End With
End With

For i = 1 To lngRows
    If Not dicIndex.Exists(vntData(i, 1)) Then
        'コードが見つからない
        ws1.Offset(i, 3).Value = "New"
    Else
        'コードが見つかった
        j = dicIndex.Item(vntData(i, 1))
        '原文比較
        If ws1.Offset(i, 1).Value <> ws2.Offset(j, 1).Value Then
            ws1.Offset(i, 1).Font.Color = vbBlue
        End If
        '訳文比較
        If ws1.Offset(i, 2).Value <> ws2.Offset(j, 2).Value Then
            ws1.Offset(i, 0).Font.Color = vbRed
        End If
    End If
Next i

Application.ScreenUpdating = True

MsgBox "差分チェックの結果はシート『New』に表示されます。", Title:="処理完了", Buttons:=vbInformation

End Sub

Comments

[nbotnk]

ご回答ありがとうございます。
ご教示いただいたコードを試させていただきました。
変更された訳文のコードが赤字にり、Newが表示されない、
新出ではない原文が青字になる等、残念ながら、問題解決
には至りませんでした。
実際のデータを提供できない上、原因が分かっていないので
他の方に教えていただいたコードをそのまま使っても、すぐには解決
できないようです。
ご教示いただいたコードを参考にして動作確認をしながら、
原因を突き止めたいと思います。

Answer 2

長々コードを貼るのではなく、１処理ずつ挙動確認して納得のいかない箇所のみを貼り付けて貰えると
回答しやすいです。

Comments

[nbotnk]

ご指摘の通りだと思います。正しい結果が得られない動作が多過ぎて納得のいかない箇所を特定できなかったので、コード全体を貼っていました。1処理ずつ動作確認してみます。

Answer 3

誤動作ではなく、比較対象のシートの内容が変わったことによる正しい動作ではないですか?
誤動作と思っている"D列に「New」と設定する"、"コードを赤字に設定する"、"原文を青字に設定する"ところにbreak pointを設定した状態でマクロを起動して、何故設定するかを検証してはいかがでしょうか?

Comments

[nbotnk]

ご回答ありがとうございます。
ご指摘の通りだと思うのですが、どこが変わったているのかが
分からないのです。見たところ、変わっているのはフォントだけで、
それを合わせても、これまで通りに正しく動作しないのです。
引き続き、検証してみます。

[sage]

等しいと思っているのに違うと判定する(赤字になってしまう)行だけのサンプルデータを提供してもらえれば、誰かがその理由を検証できるかもしれません。

Answer 4

配列とかdictionaryとか使っても、
セルの書式設定は結局セルを操作しないといけないんで、
どうなんでしょう？やってみないとわかりませんが。。。。（確かめる元気はないのですが＾＾；）

あと、セルの書式設定を個別にやっていくと、
大量のデータだと、
ファイルが無駄に大きくなって使いずらいかもしれません。
纏めて出来るところはまとめてやった方がいいと思います。

Sub test()
    Dim rngOld As Range
    Dim rngNew As Range
    
    Set rngOld = Worksheets("Old").UsedRange
    Set rngNew = Worksheets("New").UsedRange
    
    rngNew.FormatConditions.Delete
    rngNew.Columns(1).FormatConditions.Add(Type:=xlExpression, Formula1:=GetFormula(rngOld, 2)).Font.Color = vbRed
    rngNew.Columns(3).FormatConditions.Add(Type:=xlExpression, Formula1:=GetFormula(rngOld, 3)).Font.Color = vbBlue
    rngNew.Columns(4).Formula = GetFormula(rngOld, 0)
End Sub

Function GetFormula(ByRef rngList As Range, ByVal ixCol As Long) As String
    Const cFormula1 As String = "=INDEX(XXXX,MATCH($A1,YYYY,0),ZZZZ)<>TTTT"
    Const cFormula2 As String = "=IF(COUNTIF(XXXX,YYYY),"""",""New"")"
    Dim f As String

    If ixCol > 0 Then
        f = Replace(cFormula1, "XXXX", rngList.Address(, , , True))
        f = Replace(f, "YYYY", rngList.Columns(1).Address(, , , True))
        f = Replace(f, "ZZZZ", ixCol)
        f = Replace(f, "TTTT", rngList(1, ixCol).Address(False, True))
    Else
        f = Replace(cFormula2, "XXXX", rngList.Columns(1).Address(, , , True))
        f = Replace(f, "YYYY", rngList(1, 1).Address(False, True))
    End If
    
    GetFormula = f
End Function

Comments

[nbotnk]

ご回答ありがとうございます。
ご教示いただいたコードを試させていただきました。
新出ではないコードが赤字になる、原文ではなく訳文が青字になる、
Newが正確に表示されない(新出、変更された訳文セルの右隣り)等、
残念ながら、問題解決には至りませんでした。
実際のデータを提供できない上、原因が分かっていないので
他の方に教えていただいたコードをそのまま使っても、すぐには解決
できないようです。
ご教示いただいたコードを参考にして動作確認をしながら、
原因を突き止めたいと思います。

[mattuwan]

所詮、手動ですることを自動化しただけですので、
シート上の設定や数式をみて微調整していただけたら、いいかと。
で、結果は間違ってるかもしれませんが、
処理は何秒ぐらいで終わります?
上手く設定出来れば処理の秒数はほぼほぼ変わらないかとは思いますが。

[nbotnk]

処理は一瞬で終わりました。
今後のマクロ作成の際にも参考にさせていただきます。

[mattuwan]

了解です。ありがとうございます。
シート上の位置が説明と微妙に違うのでしょうか？
数式を変更すれば行けると思いますが、
デバッグのしようがないので、ご了承願います。
あ、処理速度は現状のコードでも不満はなかったでした？
なんだか、他の質問も読んでごっちゃにしてたかもです失礼しました。

[nbotnk]

処理速度は現状のコードでも不満はなかったです。1秒ほどです。
これまでは正確な結果が得られていたので、まずは原因を突き止め、
その上で適切なコードが分からなかったら、改めて質問しようと思います。