スキルアップ・問題解決なら、モーグにおまかせ！

Excel vba にて簡単なチャットボットを作りたいと考えて、ネットで検索した
内容をつぎはぎして作ってみました。
 
仕様:
・「問い合わせ」シートと「回答」シートがあります。
・「問い合わせ」シートのB3-J12のセルを結合して、質問を書けるようにしました。
・　回答は、「問い合わせ」シートのB14-J23を結合した所に記載するようにしております。
・「問い合わせ」に質問を記載して、横のボタンを押すことで、「回答」シートの中にある
問い合わせ一覧から回答を見つけてB14-J23に記載するようにしております。
 
●そこで、質問なのですが、今回のコードでは、最初に見つかった回答内容だけ表示するのですが、
できれば、質問の単語の内容を回答から全て見つけて回答に表示できるようにしたいのです。
可能でしょうか
 
お忙しいとは思いますが宜しくお願い致します。
 
下記がボットのコードです。
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
Function SearchAnswer(question As String) As String
' Split the question into an array of individual words
Dim answerSheet As Worksheet
Set answerSheet = ThisWorkbook.Worksheets("回答")
Dim lastRow As Long
lastRow = answerSheet.Cells(Rows.Count, 1).End(xlUp).Row ' Get the last row in column A
 
' Split the question into an array of individual words
Dim questionWords() As String
questionWords = Split(question, " ")
 
' Search each row in the answer sheet for a matching question and return the corresponding answer
Dim i, j As Long
Dim bestMatch As String
Dim bestMatchScore As Long
For i = 1 To lastRow
    Dim answerWords() As String
    answerWords = Split(answerSheet.Cells(i, 1).Value, " ") ' Split the answer into individual words
     
    Dim matchCount As Long
    matchCount = 0
     
    ' Check if each individual word in the question appears in the answer
    For j = LBound(questionWords) To UBound(questionWords)
        If InStr(1, answerSheet.Cells(i, 1).Value, questionWords(j), vbTextCompare) > 0 Then
            matchCount = matchCount + 1
        End If
    Next j
     
    ' If all the words in the question appear in the answer, return that answer
    If matchCount = UBound(questionWords) - LBound(questionWords) + 1 Then
        If matchCount > bestMatchScore Then
            bestMatch = answerSheet.Cells(i, 2).Value
            bestMatchScore = matchCount
        End If
    End If
Next i
 
' If no matching answer is found, return a default response
If bestMatch = "" Then
    SearchAnswer = "申し訳ありません。該当する回答が見つかりませんでした。"
Else
    SearchAnswer = bestMatch
End If
End Function
 
 
 
Sub ChatBot()
' Display initial message on first run
Dim question As String
question = Range("B3").Value
 
' Search for answer and output
Dim answer As String
answer = SearchAnswer(question)
Range("B14").Value = answer
End Sub

細かい部分の仕様が良く判りませんが
 
シート 問い合わせ B3セルの値 について 半角スペースで 区切った 単語群（questionWords）を
シート 回答 の A列の値から探し、値が見つかったら、見つかった同じ行のB列の値を
　　変数（Answer）に取得し
　　A列の最終行まで同様の処理を
単語群の、最後の単語まで繰り返し
 
 

引用:
Sub Sample()
  Dim question As String
  Dim questionWords() As String
  Dim i As Long
  Dim j As Long
  Dim Answer As String
 
  question = Worksheets("問い合わせ").Range("B3").Value
  questionWords = Split(question, " ")
 
  With Worksheets("回答")
    Answer = ""
    For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
      For j = LBound(questionWords) To UBound(questionWords)
        If InStr(1, .Cells(i, 1).Value, questionWords(j), vbTextCompare) > 0 Then
          Answer = Answer & .Cells(i, 2).Value & " "
        End If
      Next j
    Next i
  End With
  If Answer = "" Then Answer = "申し訳ありません。該当する回答が見つかりませんでした。"
  Worksheets("問い合わせ").Range("B14").Value = Answer
End Sub

 Suzuさん
 
ありがとうございました。
一発で解決しました。
 
あとの調整について頑張りたいと思っております。