Excel VBA: like演算子の応用

Question

別シートのリストと照合して「～を含むが・・・は含まれない」をチェックし、
条件にあてはまるものがあれば、「NG」などのフラグを付けたいと思っています。

データの構成は次のような感じです。
sheet1のA列に原文テキスト、B列に訳文テキスト
sheet2のA列に原文キーワード、B列にその訳文

このようなデータで、原文キーワードが含まれている原文テキストの訳文に、
訳文キーワードが含まれていない場合、フラグを付けることはできないでしょうか？

別シートのキーワードを参照するのでなければ、次のようなコードで
ほぼ期待通りの結果が得られました。
原文(A列)に「kein」が含まれているが、訳文(B列)に「ない」が含まれていない場合、
C列に赤字で「NG」と表示させています。

例：
Sub NegForm_Check()

Dim i As Long
Dim c As Integer

c = Range("A11").End(xlDown).Row

For i = 11 To c

If LCase(Cells(i, 1).Value) Like "*kein*" Then
   If Not Cells(i, 2).Value Like "*ない*" Then
      Cells(i, 3).Value = "NG"
      Cells(i, 3).Font.ColorIndex = 3
   End If
End If

Continue:
Next i
End Sub

これを、いくつかのキーワードがリストアップされているsheet2と照合して
NG箇所を見つけられないかと考えているのです。
sheet2のデータを配列に入れたらと思っているのですが、うまく行きません。
何か良い方法はないでしょうか。

Comments

[nanami12]

ただ、単に条件式の問題なので、実現できます。

[nbotnk]

データの構成をさらに詳しく説明します。
シート1のA列11行目以降にドイツ語、B列11行目以降にその日本語訳
シート2には、例えば、否定形を示すkein、keiner、keines、keinem、keinen、
nicht、nichtsと、それに該当する日本語訳がリストアップされています。つまり、
原文が否定形になっているのに、訳文が否定形になっていない箇所（誤訳の可能性あり）
を見つけたいと思っているのです。
テキスト等の情報は出せないのですが、この他に何か説明が必要な点があれば
お知らせください。よろしくお願いします。

[nbotnk]

すみません。追記に入力ミスがありましたので、投稿後に何度か修正しました。

[nbotnk]

何度もすみません。補足します。
シート2は必ずしも対になっていません。
例えば、否定を示すnichtに対して、訳文は「ない、なし、なく、なかった」
のように複数のパターンを考慮しなくてはなりません。

[yuuskeccho]

sheet1の構造はなんとなくわかりましたが、sheet2の構造のイメージが掴めません。
実際に使用しているものは提示しなくても構いませんが、サンプルを作成して提示してもらえませんか？

[nbotnk]

今、sheet2の構造を試行錯誤しているところです。
最初に入力していたのは次のような感じです。

A列 　　　B列
kein ない
keiner なし
keines なく
keine なかった
keinem なければ
keinen 非
nicht 不
nichts
ohne

A列とB列がペアになっていないことや、一つの単語に
対して複数の可能性があることが問題になっています。

Answer 1

こういうことでしょうか？（動作未確認）

Sub NegForm_Check()

    Dim r As Long
    Dim r2 As Long
    Dim rowmax As Long
    Dim shTXT As Worksheet  ' テキストシート
    Dim shKW As Worksheet   ' キーワードシート

    Set shTXT = Worksheets("sheet1")
    Set shKW = Worksheets("sheet2")

    rowmax = shTXT.Range("A11").End(xlDown).Row

    For r = 11 To rowmax
        r2 = 1
        Do While shKW.Cells(r2, 1) <> ""
            If LCase(shTXT.Cells(r, 1).Value) Like "*" & LCase(shKW.Cells(r2, 1).Value) & "*" Then
                If Not shTXT.Cells(r, 2).Value Like "*" & shKW.Cells(r2, 2).Value & "*" Then
                    shTXT.Cells(r, 3).Value = "NG"
                    shTXT.Cells(r, 3).Font.ColorIndex = 3
                    Exit Do
                End If
            End If
            r2 = r2 + 1
        Loop
    Next r

End Sub

コメントに書いた、１セルにカンマ区切りで詰め込んだ場合のを作ってみました。

Sub NegForm_Check()

    Dim r As Long
    Dim r2 As Long
    Dim rowmax As Long
    Dim shTXT As Worksheet  ' テキストシート
    Dim shKW As Worksheet   ' キーワードシート
    Dim flg As Boolean

    Set shTXT = Worksheets("sheet1")
    Set shKW = Worksheets("sheet2")

    rowmax = shTXT.Range("A11").End(xlDown).Row

    For r = 11 To rowmax
        r2 = 1
        Do While shKW.Cells(r2, 1) <> ""
            If LCase(shTXT.Cells(r, 1).Value) Like "*" & LCase(shKW.Cells(r2, 1).Value) & "*" Then
                flg = False
                Dim words() As String
                words = Split(shKW.Cells(r2, 2).Value, ",")
                For Each word In words
                    If shTXT.Cells(r, 2).Value Like "*" & word & "*" Then
                        flg = True
                        Exit For
                    End If
                Next
                If Not flg Then
                    shTXT.Cells(r, 3).Value = "NG"
                    shTXT.Cells(r, 3).Font.ColorIndex = 3
                    Exit Do
                End If
            End If
            r2 = r2 + 1
        Loop
    Next r

End Sub

Comments

[ttyp03]

おっと、一つ目の条件は右辺もLCaseつけないとだめですね。
修正します。

[nbotnk]

ご回答くださり、ありがとうございます。
こちらの説明が不足していたからだと思いますが、ご紹介いただいた
コードの動作確認を行ってみたところ、原文テキストに原文キーワード
が含まれているすべてのケースでNGが付いてしまいました。
キーワードリストの書き方に工夫が必要なのかもしれません。
一つの原文キーワードに対して複数の許容される訳文があるので、
それらを考慮した上で工夫してみます。
後でまた続報します。

[ttyp03]

まあ、そうなりますよね。
和訳って必ず同じ言葉になるわけではないですし、意訳したらその単語自体出てこない可能性もありますし。

[nbotnk]

修正ありがとうございます。
やはりNGが付き過ぎてしまいます。
例えば、原文に否定を示す「nicht」が含まれている時、訳文に
「ない、なし、なく、なかった、なければ」等が含まれている場合は
NGが付かないようにしたいのです。

[ttyp03]

sheet2のB列のデータの持ち方を工夫する必要がありますね。
B列に単語を詰め込むか、B列以降に分けて書くか、など。

[nbotnk]

B列に単語を詰め込むとは、どういう意味でしょうか？
行を分けて該当するキーワードを列挙するのでしょうか、それとも
同じセル内で改行、またはカンマ等で区切って列挙するのでしょうか？
ちなみに、前者はうまく行きませんでした。

[ttyp03]

後者です。
> 同じセル内で改行、またはカンマ等で区切って列挙するのでしょうか？

[ttyp03]

作ってみたので確認してもらえますか。

[nbotnk]

度々コードをご教示くださり、ありがとうございます。
sheet2を修正し、いただいたコードで動作を確認したところ、
ほぼ期待通りの結果が得られました。
ありがとうございました。

Answer 2

こういうこと？

Option Explicit

Sub test()
    Dim rngResult As Range
    Dim rngText As Range
    Dim rngKeyWord As Range
    
    Set rngText = Worksheets(1).Range("A1").CurrentRegion
    With Worksheets(2).Range("A1").CurrentRegion
        Set rngKeyWord = .Cells
        Set rngResult = .Columns(3).Cells
    End With
    
    ChkExistence rngText.Value, rngKeyWord.Value, rngResult.Cells
End Sub

Function ChkExistence(ByVal vrtText As Variant, ByVal vrtKeyWrod, ByRef Rng As Range)
    Dim i As Long, j As Long
    Dim vv As Variant
    Dim v As Variant
    Dim flg As Long
    Dim p As String
    
    vv = Rng.Value
    For i = LBound(vrtText, 1) To UBound(vrtText, 1)
        flg = chkKey(vrtText(i, 1), vrtKeyWrod(i, 1))
        flg = flg + chkKey(vrtText(i, 2), vrtKeyWrod(i, 2))
        Select Case flg
            Case 0: p = "Nothing"
            Case -1: p = "NG"
            Case -2: p = "OK"
        End Select
        vv(i, 1) = p
    Next
    Rng.Value = vv
End Function

Function chkKey(ByVal sText As String, ByVal sKeys As String) As Boolean
    Dim v As Variant
    
    For Each v In Split(sKeys, ",")
        If InStr(1, sText, v) Then Exit For
    Next
    If Not IsEmpty(v) Then chkKey = True
End Function

含まれるかどうかはInstr関数で評価しました。
（仕様を満たしているか自信無し＾＾；）

Comments

[nbotnk]

サンプルコードをご教示くださり、ありがとうございます。
動作確認をしたところ、sheet２のC列の1行目と2行目に
「Nothing」と表示され、Sheet1の該当箇所に「NG」は表示され
ませんでした。私の説明が足りなくて、うまく伝わらなかったようです。
ご教示いただいたコードは、今後のツール作成の際に参考とさせて
いただきます。ありがとうございました。