質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.34%

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

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 864

mls7ul1007

score 5

前提・実現したいこと

簡単な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("漢字PC")
        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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

0

ThisWorkBookはマクロブック(マクロブックから実行していますよね?)なので、

  先シート.Application.ThisWorkbook.Name


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

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


で取得できるはずです。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/05/11 21:42

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

    キャンセル

  • 2020/05/11 22:12

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

    キャンセル

  • 2020/05/12 21:34

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.34%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る