シート名をフォルダ名に変更

こんにちは、質問失礼いたします。
下記コードで、選択したフォルダ内のexcelのファイル名とシート名の一覧を出し、シートをクリックし、bookを選択するとそのbookにシートを張り付けているのですが、
張り付けるときにシート名をフォルダの名前に変更したいです。

bookの名前への変更方法はわかったのですが、格納しているフォルダの名前への変更方法が分からなかったため質問いたしました。

分かる方お教えください、宜しくお願い致します。

下記、コードです。

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) 'エクセルファイル名取得'
If InStr(Sheets(k).Name, Range("A1").Text) > 0 Then
sn(x, 2) = Sheets(k).Name 'シート名取得
x = x + 1
End If
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

No.1 ベストアンサー 回答者： fujillin 回答日時： 2021/12/01 17:38

こんにちは

ご提示のコードでは、シート名の設定を行っている様には見受けられません。
（成り行きになっているのでは？）

＞bookの名前への変更方法はわかったのですが、～
それと同様にして、book名の代わりにフォルダ名を設定すれば良いだけではないでしょうか？

具体的には、
＞.Sheets(fn).Copy Before:=ptBk.Sheets(1)
で、シートのコピーを行っていますので、1番目のシート名（＝ .Name属性)を設定すれば良いと思われます。
コードをよく見てはいませんけれど、フォルダ名そのものが存在するのかわかりませんけれど、もしかすると、パスから最後の「\」以降を文字列として切り取る必要があるのかもしれません。
（どこかにフォルダ名があるなら、そちらを利用すればよいです）

なお、設定前に、すでにブック内に同名のシートが存在していないかを確認しておいた方がよさそうに思われます。