＞□投稿者/ あいか -(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のコードが含まれています。

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