ブック名を拡張子なしで別ブックへ転記

Question

前提・実現したいこと

簡単なVBAコードしか分からない初心者です。
ブックから別ブックへ更新データを最終行の下へ値を追加する作業をしています。ファイルは3つありまして、1つはマクロブック、残り2つはxlsxです。この中のファイルxlsxのブック名だけを拡張子なしで転記したいと思っています。ブック名の転記は、C:\Users‥などから始まる部分は省きます。
⑴で取得したファイルを拡張子なしでブック名をコピーした後、
⑵で取得したファイルへ転記したいと思っています。
どなたかご教授お願いします。

発生している問題・エラーメッセージ

⑶のコードの場合ですとブック名は、マクロブック名が転記されてしまって、目的の名が転記されない上、拡張子も付いてきてしまいます。

エラーメッセージ

該当のソースコード

ソースコード
Sub Book1()
　　Dim 取得 As Variant
    Dim 取得2 As Variant　　　　　　　'⑴マクロブックからファイルを取得
 　　　　取得 = ThisWorkbook.Worksheets("Sheet1").Range("A2").Value　       
 　　　　　　　　　　　　　　　　　　　　'⑵マクロブックからファイルを取得
　　　　　取得2 = ThisWorkbook.Worksheets("Sheet1").Range("A3").Value
'
    Dim もと As Workbook
    Dim コピー先 As Workbook　　
　　　　　　　'コピー先及びコピー元のファイルを開く(コピー元は読み取り専用)
        Set もと = Workbooks.Open(取得, ReadOnly:=True)
        Set コピー先 = Workbooks.Open(取得2)

    Dim 先シート As Worksheet
    Dim 元シート As Worksheet　　　　'コピー先及びコピー元のシートを指定
        Set 元シート = もと.Sheets("漢字ＰＣ")
        Set 先シート = コピー先.Sheets("市町村")

  Dim intRowIdxA As Integer
  Dim intRowIdxB As Integer　　　'最終行を取得
        intRowIdxA = 先シート.Cells(Rows.Count, 1).End(xlUp).Row  
        intRowIdxB = intRowIdxA + 1  


 ' 番号を別ブックへ値を転記
先シート.Cells(intRowIdxB, "A") = 元シート.Cells(75, "D").Value
           
    ' 日付を別ブックへ値を転記
先シート.Cells(intRowIdxB, "C") = 元シート.Cells(5, "L").Value

'⑶ファイル名を別ブックへ転記
 Dim sname As String
    sname = 先シート.Application.ThisWorkbook.Name
        先シート.Cells(intRowIdxB, "B").End(xlUp).Offset(1, 0) = sname
'
' オートフィルターで"■"を抽出する
元シート.Range(元シート.Cells(88, "B"), 元シート.Cells(intRowIdxA, "B"). _
    End(xlUp)).AutoFilter 1, "■"


' 抽出したデータを別ブックへ値を転記
元シート.Range(元シート.Cells(89, "C"), 元シート.Cells(intRowIdxA, "C") _
.End(xlUp)).Copy

先シート.Cells(intRowIdxB, "D").End(xlUp).Offset(1, 0). _
     PasteSpecial xlPasteValues


 ' 抽出したデータを別ブックへ値を転記
元シート.Range(元シート.Cells(89, "D"), 元シート.Cells(intRowIdxA, "D") _
.End(xlUp)).Copy

先シート.Cells(intRowIdxB, "E").End(xlUp).Offset(1, 0). _
     PasteSpecial xlPasteValues


'  抽出したデータを別ブックへ値を転記
元シート.Range(元シート.Cells(89, "E"), 元シート.Cells(intRowIdxA, "E") _
.End(xlUp)).Copy

先シート.Cells(intRowIdxB, "F").End(xlUp).Offset(1, 0). _
     PasteSpecial xlPasteValues
 

 '識別1または2を判定して別ブックへ転記
  If 元シート.Cells(73, "D").Value = "カタカナ" Then
        先シート.Cells(intRowIdxB, "G").Value = 1
     
        ElseIf 元シート.Cells(73, "D").Value = "テスト" Then
         先シート.Cells(intRowIdxB, "G").Value = 2

             ElseIf 元シート.Cells(73, "D").Value = "該当なし" Then
        先シート.Cells(intRowIdxB, "G").Value = " "
      
      End If
End Sub

試したこと

補足情報（FW/ツールのバージョンなど）

Excel2013

Answer 1

ThisWorkBookはマクロブック（マクロブックから実行していますよね？）なので、

  先シート.Application.ThisWorkbook.Name

はマクロブック名が入ります。
求めているブック名が「コピー先」のブック名であれば、

'⑶ファイル名を別ブックへ転記
 Dim sname As String
    sname = コピー先.Name

で取得できるはずです。

Comments

[mls7ul1007]

迅速な対応ありがとうございます。
ご回答頂いたやり方でほぼ出来ました。
こちらに追加でもう一点なんですが、xlsx←この拡張子もカットして転記する方法はありますか？

[hope_mucci]

拡張子がわかっていれば自力で削ればいいんじゃないでしょうか。
len関数で文字長がわかるのでmid関数でlen-5文字分抜いてくる、とか。

[mls7ul1007]

ご回答頂いた内容で解決することが出来ました。
ありがとうございました。