EXCLE VBA シートクリックしたら該当シートコピー

Question

初めまして

VBAでダイアログボックスで選択したフォルダ内の、EXCLEファイル名とシート名一覧を出すものを作りました。
画像のようにシート名をクリックするとそのシートをコピーしたいと考えています。
上記の事は出来ますでしょうか。出来るなら教えていただきたいです。
よろしくお願い致します。


下記コードです。

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

Qchan1962 · Accepted Answer

こんばんは、
貼り付け先がしていないと言う事はコピーしたシートがある新規ブックを作るで良いのでしょうか、、、
何れに致しましてもシングルクリックではイベントが無いので
ダブルクリックイベントを使うのが良いのでは無いかと思います。
書き出したシートモジュールに
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fn As String, bk As String, pth As String
pth = Range("A3").Value
bk = Target.Offset(, -1).Value
fn = Target.Value
With Workbooks.Open(pth & "\" & bk)
.Sheets(fn).Copy

End With
Cancel = True
End Sub

Sheets(k).Nameで取得しているのでWorksheetsは使いませんでした。

書き出したのだからないと言う事は無いと思いますが、表組みが変わると
エラーが返る可能性がありますので対処してください。

ブックを作らないのなら、Destinationでコピー先オブジェクトを指定してください。

EXCLE VBA シートクリックしたら該当シートコピー

こんばんは、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング