シート名でファイル検索する

質問失礼いたします。

やりたいことに関しましては、
シート名を入力するとExcelファイルを検索し、該当シートをコピーすることです。
※画像参照
A1に果物といれ検索を押下し、フォルダを選択したら、シート名が果物とつくものだけ表示したい。


色々教えていただき、下記コードで、シートの一覧を出しコピーまでは出来たのですが
シート名での検索方法が分からないです。
フィルタを用いれば出来るのですが、該当シートをコピーして貼るという作業が多く、フィルタを用いらずにやりたいと思っています。
分かる方いましたらお教えください。宜しくお願い致します。

下記、コードです。

Sub 検索()
Dim fn(10000) 'フォルダ内ファイル名
Dim sn(10000, 2) 'フォルダ内エクセルファイル名、シート名
Dim i As Long, j As Long, k As Long, x As Long
Dim myPath As String 'フォルダパス
Dim ext As String '拡張子検索変数


'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker) 'ダイアログ表示
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
myPath = .SelectedItems(1) 'パス取得
Else
Exit Sub
End If
End With

Application.ScreenUpdating = False '画面更新非表示

'ファイル名の取得
fn(1) = Dir(myPath & "\", vbDirectory)
i = 1
Do
i = i + 1
fn(i) = Dir

Loop Until fn(i) = ""


'シート名の取得
x = 0
For j = 1 To i - 1
ext = Mid(fn(j), InStrRev(fn(j), ".") + 1, 3) '拡張子取得
'エクセルファイルの時実行
If ext = "xls" Then
Workbooks.Open Filename:=myPath & "\" & fn(j)
For k = 1 To Sheets.Count
sn(x, 1) = fn(j) 'エクセルファイル名取得
sn(x, 2) = Sheets(k).Name 'シート名取得

x = x + 1
Next k
ActiveWorkbook.Close
End If
Next j




'シート名一覧の作成
Columns("A:B").Select
Selection.ClearContents
Cells(2, 1) = "作業フォルダ"
Cells(3, 1) = myPath
Cells(4, 1) = "ファイル名"
Cells(4, 2) = "シート名"
x = 0
Do
Cells(x + 5, 1) = sn(x, 1)
Cells(x + 5, 2) = sn(x, 2)
x = x + 1
Loop Until sn(x, 1) = ""



Range("A1").Select

Application.ScreenUpdating = True '画面更新表示


MsgBox "完了しました"

End Sub

'シート名ダブルクリックすると実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fn As String, bk As String, pth As String
Dim ptBk As Workbook, ptBk_pth As String

If Intersect(Target, Range("B5", Cells(Rows.Count, "B").End(xlUp))) Is Nothing Then Exit Sub
Cancel = True
pth = Range("A3").Value
bk = Target.Offset(, -1).Value
fn = Target.Value

ptBk_pth = Application.GetOpenFilename("Excelブック,*.xls?") 'コピー先のブック選択

If ptBk_pth = "False" Then Exit Sub 'キャンセル時終了

Application.ScreenUpdating = False '画面更新非表示

Set ptBk = Workbooks.Open(ptBk_pth)
With Workbooks.Open(pth & "\" & bk)
Application.EnableEvents = False 'イベントを抑止
.Sheets(fn).Copy Before:=ptBk.Sheets(1)
Application.EnableEvents = True

.Close savechanges:=False 'コピー元は保存せず閉じる
End With
ptBk.Close savechanges:=True 'コピー先は保存し閉じる
Application.ScreenUpdating = True '画面更新表示
Application.ActivateMicrosoftAppb = True
End Sub

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

• セルA1に入力した文字で表示したいです。
  言葉足らずですみません。

    補足日時：2021/11/30 18:20

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/11/30 18:47

"果物"　を　Range("A1").Text とすれば良いかと

If InStr(Sheets(k).Name, Range("A1").Text) > 0 Then

この回答へのお礼

返信日をまたいでしまい大変申し訳ありません。
やりたいこと完璧にできました！ありがとうございました！！

お礼日時：2021/12/01 10:40

No.1 回答者： Qchan1962 回答日時： 2021/11/30 18:02

こんばんは、

該当部分
For k = 1 To Sheets.Count
sn(x, 1) = fn(j) 'エクセルファイル名取得
If InStr(Sheets(k).Name, "果物") > 0 Then
sn(x, 2) = Sheets(k).Name 'シート名取得
x = x + 1
End If
Next k

この回答へのお礼

回答ありがとうございます。
言葉足らずですみません、セルA1に入力した文字で絞り込みたいのですが可能でしょうか。
回答してコードを示していただいたのにも関わらずすみません。

お礼日時：2021/11/30 18:19