[[20211129120435]]　『シート名でEXCELファイルを検索』（でんで）　ページの最後に飛ぶ

『シート名でEXCELファイルを検索』（でんで）

やりたいことに関しましては、
シート名を入力するとExcelファイルを検索し、該当シートをコピーすることです。
色々参考にし下記コードで、シートの一覧を出しコピーまでは出来たのですが
シート名で絞り込む方法が分からないです。
詳しい方お教えください。宜しくお願い致します。

下記コードです。

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 '画面更新表示

        End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

＞シート名で絞り込む方法が分からないです。
リストは得られているのですから、【オートフィルタ】等をつかって絞り込んでみてはどうでしょうか？
（必要な命令は「マクロの記録」で調べることができます）

（もこな２） 2021/11/29(月) 12:57

→【オートフィルタ】等をつかって絞り込んでみてはどうでしょうか？
オートフィルタを用いれば確かに出来るのですが、該当シートをコピーして貼るという作業が多く、フィルタを用いらずにやりたいと思っています。
言葉が足らず、申し訳ないです。
（でんで） 2021/11/29(月) 14:51

＞オートフィルタを用いれば確かに出来るのですが、該当シートをコピーして貼るという作業が多く、フィルタを用いらずにやりたいと思っています。
＞言葉が足らず、申し訳ないです。

どこまで自動化したいのか分かりませんので、
日本語でフローを書いたらどうでしょう。
どなたかコード化してくれるかもしれませんよ。

（tkit） 2021/11/29(月) 15:39

コメント返信：

[ 一覧(最新更新順) ]

[[20211129120435]] 『シート名でEXCELファイルを検索』（でんで） ページの最後に飛ぶ

[[20211129120435]]　『シート名でEXCELファイルを検索』（でんで）　ページの最後に飛ぶ