EXCEL VBA シート貼り付け

こんにちは、先日質問させてもらったものです。

https://oshiete.goo.ne.jp/qa/12667375.html

上記で教えていただき、シート名クリックでコピーはすることが出来ました。
コピー先を新規bookではなく、ファルダの中にあるbookにしたいと思い、調べたのですがダブルクリックが作動しなくなったなど、よくわかりませんでした。
分かる方教えて貰えないでしょうか、宜しくお願い致します。

（例　C:\Users\USER80\Documents\果物\メロン.xlsx　にダブルクリックしたシートをコピー）




下記コードです。

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

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

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2021/11/15 15:35

こんにちは

横から失礼します。
先日回答、、Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)　のコードを書いたものです。
一応、回答したスレッドにも不明な点がありましたので補足アドバイスを書いているつもりでした。

すでに＃２様が回答されている通りかと思いますが、
ダブルクリックの範囲を限定する等しておりませんでしたので
コードサンプルを書いておきます。

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

確認が必要と思い、該当ブックを閉じずに終了しています。
問題ないようでしたら
' .Close SaveChanges:=False
' ptBk.Close SaveChanges:=True
のコメントを解除してください。
まだ、Workbooks.Openについては存在する事が前提なので
しない場合のエラー処理が必要だと思います。

Sub 検索()については、私が示したものでないので考えていません。

この回答へのお礼

前回に引き続き、サンプルコードも書いていただき本当にありがとうございます。前回の最後の方にDestinationの話も頂いてたのですが、自分の理解力乏しく聞くことになり、すみません。
分からない部分など調べ、勉強励んでいきたいと思います。
改めてになりますが、２回ともサンプルコードまで示していただいてありがとうございました！
やりたいことも出来ました！

お礼日時：2021/11/15 17:31

No.2 回答者： fujillin 回答日時： 2021/11/15 13:02

こんにちは

＞ダブルクリックが作動しなくなったなど、よくわかりませんでした。
どこをどう修正したのかわかりませんけれど・・・

＞コピー先を新規bookではなく、ファルダの中にあるbookにしたいと思い
単純に、コピー時にコピー先を指定してあげれば済むと思われます。

＞.Sheets(fn).Copy
では、指定したシートを新規ブックにコピーしています。
この際に、Destinationにコピー先を指定しておけば、コピー先にコピーされるようになります。
https://docs.microsoft.com/ja-jp/office/vba/api/ …

※ コピー先がどこなのかわかりませんけれど、事前にコピー先のブックは開かれている必要があります。
※ コピー先に複数のシートが存在する場合にどこにコピーしたいのか不明ですが、BeforeやAfterの引数を利用することで位置を指定することもできるでしょう。

この回答へのお礼

リンクなども貼っていただき、ありがとうございます。
また、文での情報少なくてすみません。
やりたいことも出来ました。ありがとうございました！

お礼日時：2021/11/15 17:30

No.1 回答者： めぐみん_ 回答日時： 2021/11/15 12:45

良く見てないですが、拡張子.xlsxではマクロは動かない（マクロのないブック）ですしね。

拡張子が.xlsmのブックにしないと。
変換の手段については不勉強です。

この回答へのお礼

勉強不足で申し訳ないです。情報ありがとうございます！

お礼日時：2021/11/15 17:30