VBAで、アクティブなBOOKのファイル名を取得し

質問

エクセルのVBAを使用して、選択されている、ＢＯＯＫのファイル名を取得し、下記のように編集してＡ１セルに入れたいのですが、可能でしょうか？

BOOKのファイル名が「大阪_たこ焼き_1234.xls」の場合

大阪_と.xlsをは省いて、「たこ焼き_1234」がＡ１セルに入るようにしたい。

回答No.3

K Kazz（@JazzCorp） · ベストアンサー

拡張子なんでもござれ！
Sub TheBody()
Const xSeparator = "_"
Const xPeriod = "."
Dim KitCut As Variant
KitCut = Split(ActiveWorkbook.Name, xPeriod)
KitCut = Split(KitCut(0), xSeparator)
Range("A1").Value = KitCut(1) & xSeparator & KitCut(2)
Columns("A").AutoFit
End Sub

お礼

ありがとうございした、
とても助かりました。

回答No.4

DexMachina

> 選択されている、ＢＯＯＫのファイル名を取得し、

この「選択」というのは、「現在開いているファイル(群)」ということでしょうか、
それとも「エクスプローラー上で選択しているファイル(群)」でしょうか。

とりあえず、以下のサンプルは、「エクスプローラー上で選択する代わりに、
ファイル選択ダイアログで対象ファイル群を選択」としたものです。

Private Sub CommandButton1_Click()
On Error GoTo エラー処理

　　'VBAのメニューで「ツール(T)→参照設定(R)」を選択し、
　　'「Microsoft Office xx.x Object Library」のチェックを
　　'オンにしておく必要があります。
　　Dim Dlg As FileDialog, Sels As FileDialogSelectedItems
　　Dim Mem As Variant, Wkb As Workbook, Wks As Worksheet
　　Dim sFile As String, nUnd As Long, nDot As Long

　　'ファイル名を記録するファイル群を、ダイアログで選択
　　Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
　　With Dlg
　　　　'Shiftキーを押しながらクリックすることで複数選択を可能に設定
　　　　.AllowMultiSelect = True
　　　　'ファイルを絞り込むためのフィルタの設定
　　　　With .Filters
　　　　　　.Clear
　　　　　　.Add "Xlsファイル", "*.xls"
　　　　　　.Add "Xlsxファイル", "*.xlsx"
　　　　　　.Add "Xlsmファイル", "*.xlsm"
　　　　　　.Add "すべてのファイル", "*.*"
　　　　End With
　　　　'キャンセル選択時はそのまま終了
　　　　If .Show Then Set Sels = .SelectedItems Else GoTo 終了処理
　　End With

　　'各ファイルにファイル名を記録
　　For Each Mem In Sels
　　　　Set Wkb = Workbooks.Open(CStr(Mem))
　　　　Set Wks = Wkb.Worksheets(1)
　　　　sFile = Wkb.Name
　　　　nUnd = InStr(1, sFile, "_")　　　　'先頭の「_」の位置
　　　　nDot = InStrRev(sFile, ".")　　　　'末尾の「.」の位置
　　　　Wks.Range("A1") = Mid(sFile, nUnd + 1, nDot - nUnd - 1)
　　　　Wkb.Close True
　　Next

終了処理:
　　Set Wks = Nothing
　　Set Wkb = Nothing
　　Set Dlg = Nothing
　　Exit Sub
エラー処理:
　　MsgBox Err.Number & Err.Description, vbCritical, "CommandButton1"
　　Resume 終了処理
End Sub

・・・以上です。

お礼

ありがとうございました
参考になりました。

選択されているbookとは、開いているbookのつもりでした。

回答No.2

WindFaller

こんにちは。

質問が、どの程度、実際のものと近いか、その規則性や実用性がはっきりしていませんが、こんなことだと思います。

'//
Sub Test1()
　Dim wbName　As Variant
　Dim buf As String
　wbName = ActiveWorkbook.Name
　If InStr(wbName, ".") > 0 Then
　　buf = Mid(wbName, 1, InStr(wbName, ".") - 1)
　End If
　If InStr(buf, "_") > 0 Then
　　buf = Mid(buf, InStr(buf, "_") + 1) '区切りが、_ の場合
　End If
　'マクロのあるブックのアクティブシートのA1 （適当に調整してください）
　ThisWorkbook.ActiveSheet.Range("A1").Value = buf
End Sub

お礼

ありがとうございまいた

とても参考になりました

回答No.1

keithin

sub macro1()
with application.worksheetfunction
range("A1") = .substitute(activeworkbook.name, "大阪_", "")
range("A1") = .substitute(range("A1"), ".xls", "")
end with
end sub
とか

sub macro2()
dim res as string
res = activeworkbook.name
res = mid(res, 4,999)
res = left(res, len(res) - 4)
range("A1") = res
end sub
とか

sub macro3()
range("A1") = mid(split(activeworkbook.name, ".")(0), 4,999)
end sub
とか

お礼

ありがとうございまいた、
とても参考になりました