>後は、[196298]の処理スピードを速くしたいのです。

時間が掛かるのは、複数のブックの開閉と、セルに都度書き込んでいるセイと思われます。
前者はどうしようもないですが(私にはですが）、
後者は転記すべきデータをdictionaryにでも溜めて置き、最後に一気にセルに書き出せばいいと思います。

Sub リスト()
    Dim c As Range
    Dim i As Integer, j As Integer
    Dim FName As String
    Dim PName As String
    Dim FWhat As String
    Dim BigR As Range
    Dim fAddr As String
    Dim ThisBK As Workbook
    Dim destBK As Workbook
    Dim result(1 To 1, 1 To 3)
    Dim dicT As Object
    
    Set dicT = CreateObject("Scripting.Dictionary")
    j = 0    ' 初期化
    PName = ActiveWorkbook.Path         ' 自分（このBook)と同じフォルダのPath
    FName = Dir(PName & "\" & "*.xls")  ' その中の、*.xls ファイル
    Set ThisBK = ThisWorkbook
    ThisBK.Worksheets(1).Range("A3:C1000").ClearContents  ' A3からC1000セルまでクリア
    
    FWhat = InputBox("検索値を入力してください。")
    
    ' キャンセルボタンが押された場合、処理を終了
    If FWhat = "" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Do While FName <> ""
        If FName <> ThisBK.Name Then
            Set destBK = Workbooks.Open(Filename:=PName & "\" & FName, ReadOnly:=True)
            
            For i = 1 To destBK.Worksheets.Count
                Set BigR = destBK.Worksheets(i).UsedRange
                Set c = BigR.Find(What:=FWhat, LookAt:=xlPart)
                result(1, 1) = FName
                
                If Not c Is Nothing Then
                    fAddr = c.Address   '見つかった
                    result(1, 2) = destBK.Worksheets(i).Name
                    Do
                        result(1, 3) = c.Value
                        j = j + 1
                        dicT(j) = result
                        Set c = BigR.FindNext(c)
                        If c.Address = fAddr Then Exit Do
                    Loop
                End If
            Next
            destBK.Close False
        End If
        FName = Dir()
    Loop
    
    Application.ScreenUpdating = True
    
    If j > 0 Then '書き出し
        ThisBK.Sheets(1).Range("A3:C3").Resize(j).Value = Application.Index(dicT.items, 0)
        dicT.RemoveAll
    Else
        MsgBox FWhat & " は、このFolderのBookにはありませんでした"
    End If
End Sub

＞シートモジュールが掲示出来なくなりました。

ここの掲示板は、時々そんな異常事態になりますね(困ったもんです）。
その内、知らぬ間に解消されると思います(経験則ですが)

ただ、今はコード自体より、この疑問に対する答えがどうなのか知りたい所です。
　　　　　　　　　　　　　　↓
＞私は書く場所が「シートモジュール」で、
＞プロシージャ名が「Private Sub Worksheet_BeforeRightClick(ByVal・・」と言ったのですが、
＞何故、「標準モジュール」で「Sub リスト()」に変わったのですか？


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

すみません。問題の所在がよく分かりません。

私は書く場所が「シートモジュール」で、
プロシージャ名が「Private Sub Worksheet_BeforeRightClick(ByVal・・」と言ったのですが、

何故、「標準モジュール」で「Sub リスト()」に変わったのですか？


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

 半平太 様
お返事ありがとうございます。
モジュールを見直しました。

標準モジュール
Sub リスト()
    Dim c As Range
    Dim i As Integer, j As Integer
    Dim FName As String
    Dim PName As String
    Dim FWhat As String
    Dim BigR As Range
    Dim fAddr As String

    j = 3    ' 初期値を3に設定
    PName = ActiveWorkbook.Path         ' 自分（このBook)と同じフォルダのPath
    FName = Dir(PName & "\" & "*.xls")  ' その中の、*.xls ファイル
    ThisWorkbook.Worksheets(1).Range("A3:C1000").ClearContents  ' A3からC1000セルまでクリア
    FWhat = InputBox("検索値を入力してください。")

    ' キャンセルボタンが押された場合、処理を終了
    If FWhat = "" Then Exit Sub

    Application.ScreenUpdating = False

    Do While FName <> ""
        If FName <> ActiveWorkbook.Name Then
            Workbooks.Open PName & "\" & FName
            For i = 1 To ActiveWorkbook.Worksheets.Count
                Set BigR = ActiveWorkbook.Worksheets(i).UsedRange
                Set c = BigR.Find(What:=FWhat, LookAt:=xlPart)
                If Not c Is Nothing Then
                    fAddr = c.Address   '見つかった
                    Do
                        With ThisWorkbook.Worksheets(1)
                            .Cells(j, 1).Value = FName
                            .Cells(j, 2).Value = Worksheets(i).Name
                            .Cells(j, 3).Value = c.Value
                        End With
                        j = j + 1
                        Set c = BigR.FindNext(c)
                        If c.Address = fAddr Then Exit Do
                    Loop
                End If
            Next
            ActiveWorkbook.Close
        End If
        FName = Dir()
    Loop

    Application.ScreenUpdating = True
    If j = 3 Then MsgBox FWhat & " は、このFolderのBookにはありませんでした"
End Sub

＞□投稿者/ あいか -(2024/10/01(13:27))
　　　↑
単にここで提示された「Private Sub Worksheet_BeforeRightClick(ByVal・・以下」を
検索シートのモジュールに書いたらどうか、と言っただけなんですが・・

※コードを書く場所が違うと言うことです。
　つまり、検索シートの「シート見出し」を右クリック→「コードの表示」を選択→画面中央の白いエリアに当該コードをコピペ


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

 半平太 様
お返事ありがとうございます。
すみません。
わかりません。教えて下さい。


ub リスト()
    Dim c As Range
    Dim i As Integer, j As Integer
    Dim FName As String
    Dim PName As String
    Dim FWhat As String
    Dim BigR As Range
    Dim fAddr As String

    j = 2
    PName = ActiveWorkbook.Path         '自分（このBook)と同じフォルダのPath
    FName = Dir(PName & "\" & "*.xlsx")  'その中の、*.xlsx　ファイル
    ThisWorkbook.Worksheets(1).Range(Range("A3"), Range("A3").SpecialCells(xlCellTypeLastCell)).ClearContents
    FWhat = InputBox("英数字、記号【半角,全角】を検索します。")
    Application.ScreenUpdating = False

    Do While FName <> ""                'FNameがある限り繰り返す
        If FName <> ActiveWorkbook.Name Then
            Workbooks.Open PName & "\" & FName
            For i = 1 To ActiveWorkbook.Worksheets.Count
                Set BigR = ActiveWorkbook.Worksheets(i).UsedRange
                Set c = BigR.Find(What:=FWhat, LookAt:=xlPart)
                If Not c Is Nothing Then
                    fAddr = c.Address   '見つかった
                    Do
                        j = j + 1
                        With ThisWorkbook.Worksheets(1)
                            .Cells(j, 1).Value = FName
                            .Cells(j, 2).Value = Worksheets(i).Name
                            .Cells(j, 3).Value = c.Value
                        End With
                        Set c = BigR.FindNext(c)    '2個目以降を探す
                        If c.Address = fAddr Then Exit Do   '見つかったセル番地が最初と同じなら中止
                    Loop
                End If
            Next
            ActiveWorkbook.Close
        End If
        FName = Dir()                   '次のファイル名を探す
    Loop
    Application.ScreenUpdating = True
    If j = 1 Then MsgBox FWhat & " は、このFolderのBookにはありませんでした"
    '   Application.ScreenUpdating = False
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Me.Columns(2)) Is Nothing Then
        Cancel = True
        Me.Cells(Target.Row, 3).Select
    End If
End Sub

＞ThisWorkbookに以下を書いてみたのですが、思った通りには行きませんでした。

ThisWorkbookモジュールにではなく、検索シートのモジュールに書くべきじゃないですか？

匿名 様

ThisWorkbookに以下を書いてみたのですが、思った通りには行きませんでした。

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim FName As String
    Dim PName As String
    Dim ws As Worksheet
    
    ' B列を右クリックした場合
    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        Cancel = True ' 右クリックメニューをキャンセル
        FName = Target.Offset(0, -1).Value ' A列のファイル名を取得
        PName = ThisWorkbook.Path ' 現在のブックのパスを取得
        
        ' ファイルを開く
        Workbooks.Open PName & "\" & FName
        
        ' 対象のセルを選択
        Set ws = ActiveWorkbook.Sheets(Target.Value)
        ws.Activate
        ws.Cells(1, 1).Select ' 必要に応じてセルの位置を変更
    End If
End Sub

Windows１１　　Office２０２１です。

図１　@検索@.xlsm　Sheet : 検　索　　　図２【検索結果】
         A　　　　 B　　　　　C　　　　　　 　　A　　  　　B　　  　　C
２　ファイル名　シート名　セル内内容　　２　ファイル名　シート名　セル内内容
３　　　　　　　　　　　　　　　　　　　３  中部支店　　人事部　　 ＦＡＸ　山田
４　　　　　　　　　　　　　　　　 　　 ４  新潟営業   総務・電話 　fax
５　　　　　　　　　　　　　　　　　  　５　東京本社　  電話外線　　花子,鈴木　,FAX,
1、このマクロは、指定されたフォルダ内のすべてのExcelファイル（*.xls）を検索し、特定の英数字、記号【半角,全角】を探してリスト化するものです。
2、リスト化したＢ列のシート名を。右クリックすると、そのシートが開くようになっています。
3、検索対象Ｂｏｏｋは、３０個で、Ｓｈｅｅｔ数は８Ｓｈｅｅｔ以上です。
ご教授受けたい事は
１、図２のＢ列シート名を右クリックで、Ｃ列セル内内容を選択して開く。】
２、【検索スピードを速くしたいのです。】
宜しくお願い致します。

Sub リスト()

Dim c As Range
Dim i As Integer, j As Integer
Dim FName As String
Dim PName As String
Dim FWhat As String
Dim BigR As Range
Dim fAddr As String
    j = 2
    PName = ActiveWorkbook.Path         '自分（このBook)と同じフォルダのPath
    FName = Dir(PName & "\" & "*.xls")  'その中の、*.xls　ファイル
    ThisWorkbook.Worksheets(1).Range(Range("A3"), Range("A3").SpecialCells(xlCellTypeLastCell)).ClearContents
    FWhat = InputBox("英数字、記号【半角,全角】を検索します。")
    Application.ScreenUpdating = False
    Do While FName <> ""                'FNameがある限り繰り返す
        If FName <> ActiveWorkbook.Name Then
            Workbooks.Open PName & "\" & FName
            For i = 1 To ActiveWorkbook.Worksheets.Count
                Set BigR = ActiveWorkbook.Worksheets(i).UsedRange
                Set c = BigR.Find(What:=FWhat, LookAt:=xlPart)
                If Not c Is Nothing Then
                    fAddr = c.Address   '見つかった
                    Do
                        j = j + 1
                        With ThisWorkbook.Worksheets(1)
                            .Cells(j, 1).Value = FName
                            .Cells(j, 2).Value = Worksheets(i).Name
                            .Cells(j, 3).Value = c.Value
                        End With
                        Set c = BigR.FindNext(c)    '2個目以降を探す
                    If c.Address = fAddr Then Exit Do   '見つかったセル番地が最初と同じなら中止
                    Loop
                End If
            Next
            ActiveWorkbook.Close
        End If
        FName = Dir()                   '次のファイル名を探す
    Loop
    Application.ScreenUpdating = True
    If j = 1 Then MsgBox FWhat & " は、このFolderのBookにはありませんでした"
    
 '   Application.ScreenUpdating = False

Application.ScreenUpdating = True
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他