WORD VBA プログラム修正をお願いします。

以下のWORD VBAは選択したテーブル内のデータをワイルドカード検索し、抽出されたデータを重複非表示、降順ソートでMSGBOXに表示するものです。　問題が出ております。それが、WORDファイルに4つのテーブルがあるとして、最初のテーブルを選択して検索すると、2番目から4番目のテーブルにあるデータも一緒に検索されてしまいます。2番目のテーブルで検索すると、3から4番目のデータが、3番目のテーブルで検索すると、4番目のデータが一緒に表示されてしまいます。4番目のテーブルを選択した時のみ、4番目のデータが表示されます。　下のVBAは選択したテーブル内で検索していると思うのですが、どこに問題があるかわかりません。どなたか教えていただけないでしょうか、よろしくお願い致します。

Sub SearchUniqueAndDisplaySelectedTable()
Dim tbl As Table
Dim rng As Range
Dim result As String
Dim foundItems As New Collection
Dim item As Variant
Dim i As Integer

' 選択されたテーブルを取得します
Set tbl = Selection.Tables(1)

' 結果を格納する変数を初期化します
result = ""

' テーブル内のすべてのテキストを検索します
For Each rng In tbl.Range.Cells
' セル内のテキストを検索します
With rng
With .Find
.Text = "XYZ Reg. on 20[0-9]{1,2}/[0-9]{1,2}/[0-9]{1,2}"
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
' ワイルドカード検索を実行します
If .Execute Then
' 重複したデータをチェックして追加します
If Not foundItemsExists(.Text, foundItems) Then
foundItems.Add .Text, .Text
End If
End If
End With
End With
Next rng

' 検索結果を配列に変換します
Dim resultsArray() As Variant





ReDim resultsArray(foundItems.Count - 1)
For i = 1 To foundItems.Count
resultsArray(i - 1) = foundItems(i)
Next i

' 配列を降順にソートします
Call SortArray(resultsArray)

' 結果を文字列に変換します
For i = LBound(resultsArray) To UBound(resultsArray)
result = result & resultsArray(i) & vbCrLf
Next i

' 結果を表示します
If result <> "" Then
MsgBox "検索結果:" & vbCrLf & result, vbInformation, "検索結果"
Else
MsgBox "指定された文字列が見つかりませんでした。", vbExclamation, "検索結果"
End If
End Sub
-------------------------------------------------------------------------------------------
Function foundItemsExists(item As Variant, collection As Collection) As Boolean
On Error Resume Next
foundItemsExists = Not IsEmpty(collection(item))
On Error GoTo 0
End Function
-----------------------------------------------------------------------------------------
Sub SortArray(ByRef arr As Variant)
Dim i As Long, j As Long
Dim temp As Variant

For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) < arr(j) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub

質問者からの補足コメント

• fujillin様
  
  早速ご連絡いただきありがとうございます。
  動作しないとご連絡いただき、調べたところ、不注意にも、模索中で動かなったファイルをコピー添付してしまいました。真に申し訳ありません。恐縮しています。再度添付させていただきます。これが、動作はしますが、他のテーブルのデータを拾ってしまいます。お手数ですが、再度ご検討いただければ幸いです。　補足本文の文字数がオーバーになりますので、次の補足で関係箇所だけ添付します。

  No.1の回答に寄せられた補足コメントです。 補足日時：2024/04/26 18:06

• ' 選択されたテーブル内の各セルに対して処理を行います
  For Each cell In tbl.Range.Cells
  ' セル内のテキストを検索します
  Set rng = cell.Range
  With rng.Find
  .Text = " XYZ Reg. on 20[0-9]{1,2}/[0-9]{1,2}/[0-9]{1,2}*"
  .Forward = True
  .Wrap = wdFindStop
  .MatchWildcards = True
  ' ワイルドカード検索を実行します

    補足日時：2024/04/26 18:09

• Do While .Execute
  ' 重複したデータをチェックして追加します
  If Not foundItemsExists(rng.Text, foundItems) Then
  foundItems.Add rng.Text, rng.Text
  End If
  Loop
  End With
  Next cell
  
  文字数の関係で細分化されてしまい申し訳ありません。

    補足日時：2024/04/26 18:12

No.2 ベストアンサー 回答者： fujillin 回答日時： 2024/04/27 11:22

No1です。

補足の内容は、処理の手順としては何も変わってないですよね？

例えば、カウンターを作って、No1で挙げた2）で、「処理したセル数」をカウントしてみると、指定した表のセル数よりも多くなっているということですか？
（ご質問の内容は『ループが想定通りになっていない』という問題なので、細かな処理内容は関係ないはずです）

そのあたりから順に確認すれば、原因がわかるのではというのがNo1の回答なのですが・・
（当方の環境とは全く異なる環境のようなので、こちらでは調べようがありません）

この回答へのお礼

fujillin様
再度のご指摘ありがとうございました。選択ターブルのセル数と内容を確認し、選択テーブルで間違いないことを確認し、問題は検索処理にあることがわかりましたので、検索方法を見直し、希望通りの結果をえることができました。ありがとうございました。基本的なことをご指導いただきましたので、ベストアンサーとさせていただきました。

お礼日時：2024/04/28 12:05

No.1 回答者： fujillin 回答日時： 2024/04/26 14:38

こんにちは

ご提示のマクロは、そのままでは私の環境ではまったく動作しませんけれど・・
（バージョンの問題なのか、環境の問題なのかは不明ですが）

ロジック的に、
　＞Set tbl = Selection.Tables(1)
　＞For Each rng In tbl.Range.Cells
としているのに、他のテーブルまで対象にしてしまうというご質問と解釈しました。

ご提示のマクロをあちこち修正して、ロジックはそのままで、ひとまず動作するようにしてテストしてみましたが、ご質問にあるように『他のテーブルまで検索対象にしてしまう』ような事象は発生しませんでした。

当方では事象が再現しないため、回答にはなっていませんけれど、
　1）tblオブジェクトに目的の表だけが取得できているか
　2）For Each のループ変数が、対象tbl内だけで循環しているか
などを確認してみれば、原因が掴めるのではないでしょうか？

ご質問には直接関係ありませんけれど、With構文をネストしているので、その中で省略形を用いる場合に、どちらの親オブジェクトが参照されるのかについては注意なさった方がよさそうに思われます。