• 締切済み

ファイルのフルパス splite?InstrRev?

お世話になります。 エクセル2003のVBAについての質問なのですが、 ファイルパスを分割して、変数に格納したいと考えております。 具体的には、現在のワークブックのパスである C:\○○○\○○○\ABC\test1\test2.xls というフルパスを「C:\○○○\○○○\ABC\」と「\test1\test2.xls」 に分割して、「\test1\test2.xls」だけを変数に格納して他の箇所に 利用したいのです。 下記を試してみたのですが、これでは、「test2.xls」のみしか取得することができません…。 Sub Sample1() Dim PathName As String, FileName As String, pos As Long pos = InStrRev(ThisWorkbook.Path, "\") FileName = Mid(ThisWorkbook.Path, pos + 1) End Sub 一つ上のフォルダ名を含む「\test1\test2.xls」を取得するにはどうすればいいでしょうか。

みんなの回答

  • AKARI0418
  • ベストアンサー率67% (112/166)
回答No.4

Sub Test() Dim str As String Dim kaiso As Long kaiso = 2 str = "C:\○○○\○○○\ABC\test1\test2.xls" str = GetPath(str, kaiso) End Sub Public Function CntStr(s As String, org As String) As Long Dim i As Long Dim j As Long Dim k As Long k = Len(org) i = 1 j = 0 Do i = InStr(i, s, org) If i > 0 Then i = i + k j = j + 1 End If Loop Until i = 0 CntStr = j End Function Public Function GetPath(s As String, kaiso As Long) As String Dim i As Long Dim j As Long Dim k As Long k = CntStr(s, "\") If kaiso = 0 Then GetPath = "" Exit Function ElseIf kaiso > k Then GetPath = "" Exit Function End If j = 0 For i = 0 To k - kaiso j = InStr(j + 1, s, "\") Next i GetPath = "\" & Right(s, Len(s) - j) End Function こんな感じでいかがでしょうか? GetPathにパスと、階層を指定することで、文字列を分割してくれます。

noname#140971
noname#140971
回答No.3

失礼! '\'は、除去されないみたいですね。 仮に除去される場合は・・・ ? Cutstr("C:\○○○\○○○\ABC\test1\test2.xls", "\" & CutStr("C:\○○○\○○○\ABC\test1\test2.xls", "\", 5) ,1) C:\○○○\○○○\ABC と、区切り文字に含めればよいです。

  • fujillin
  • ベストアンサー率61% (1594/2576)
回答No.2

同じ考え方のままでやるなら、2番目の「¥」を探せばよいのでは? 以下の1行を挿入  If pos > 2 Then pos = InStrRev(ThisWorkbook.Path, "\", pos - 1)

noname#140971
noname#140971
回答No.1

[イミディエイト] ? CutStr("C:\○○○\○○○\ABC\test1\test2.xls", "\", 1) C: ? CutStr("C:\○○○\○○○\ABC\test1\test2.xls", "\", 2) ○○○ ? Cutstr("C:\○○○\○○○\ABC\test1\test2.xls", CutStr("C:\○○○\○○○\ABC\test1\test2.xls", "\", 5),1) C:\○○○\○○○\ABC\ ? Cutstr("C:\○○○\○○○\ABC\test1\test2.xls", CutStr("C:\○○○\○○○\ABC\test1\test2.xls", "\", 4),2) \test1\test2.xls このように CutStr関数の類を用意すれば簡単に文字列を分割できます。 '\'の処理は必要ですが・・・。 Public Function CutStr(ByVal Text As String, _             ByVal Separator As String, _             ByVal N As Integer) As String   Dim strDatas() As String      strDatas = Split("" & Separator & Text, Separator, , 0)   CutStr = strDatas(N * Abs((N <= UBound(strDatas)))) End Function

関連するQ&A

  • エクセルVBAの変数利用

    シートのC1セルに入力したブック名をアクティブにするための 変数なのですが、アクティブになりません。 下のようにしていますが、とのようにすればよいでしょうか? Sub test() Dim FileName As Range FileName = ThisWorkbook.Path & "\" & Sheets("sheet1").Range("C1") & ".xls" Workbooks.FileName.Activate End Sub

  • 同じフォルダ内のブックを開きコピーする方法

    いろいろチャレンジしてみたのですが どうにも行き詰っております。 ご教示頂ければ幸いです。 1つのフォルダに3つ(数は固定)のシートがあります。 フォルダ名は毎回変わります。 C:\デスクトップ\作成 ├4328457 神戸 ├作成元データ(名前は固定)←Aとします。  ├1314 電源工事(名前は毎回変わります)←Bとします。 └見積.xls(名前は固定)←今回は使いません 毎回名前の変わるBを先に開き、下記の「FileOpen」マクロで Aを開きます。 Bにあるシート(数は変動)を全て、Aにあるシート(3枚固定)の前に コピーし、Bは閉じてしまい、Aにて作業をしたいと思います。 Sub FileOpen()   Dim Wb As Workbook   Dim Fname As String     Dim PathName As String    Set Wb = ActiveWorkbook   Fname = "作成元データ.xls" PathName = Wb.Path   If Right(PathName,1)="\" then   Workbooks.Open Filename:=PathName & Fname   Else     Workbooks.Open Filename:=PathName & "\" & Fname     ThisWorkbook.Active    End If End Sub 「ThisWorkbook.Active」にてBに戻しているつもりなのですが Aがアクティブのままであり、Bのシートをコピー選択できなくなってしまっています。 Sub BookOpen() Workbooks.Open Filename:=ThisWorkbook.Path & "\作成元データ.xls" End Sub こちらのように簡単な構図も試してみたのですが PESONAL.xlsbのあるフォルダ?を見に行くようでうまく「作成元データ」を開けませんでした。 お詳しい方には基本的な事かもしれませんが どうぞ宜しくお願い致します。   

  • VBAで複数のエクセルファイルを自動圧縮

    VBAで複数のエクセルファイルを自動圧縮 お世話になります。 以下サイトなどを参考にVBAでエクセルファイルの圧縮をさせようとしています。 ダイアログで圧縮したいファイルを指定して圧縮するところまではできました。 http://oshiete.hmv.co.jp/qa5155002.html ■やりたいこと 特定のフォルダにある複数のファイルを個別に圧縮して、それぞれzipファイルとしたい。 圧縮するファイルを指定するダイアログは出さずに、自動化したい。 ■VBAの記述 Dim Filename As String Dim strArchiveName As String Dim strCommand As String Dim RC As Long Dim hWnd As Long Dim strOutPut As String * 512 Dim lngSize As Long Dim strPassWord As String strPassWord = "pass" 'ハンドル取得 hWnd = FindWindow("XLMANI", Application.Caption) '★ファイル名取得★ Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls") If Filename = "False" Then Exit Sub Filename = Mid$(Filename, InStrRev(Filename, "\") + 1) strArchiveName = Mid$(Filename, InStrRev(Filename, "\") + 1, InStrRev(Filename, ".") - InStrRev(Filename, "\") - 1) & & ".zip" strCommand = "-uP " & strPassWord & " " & strArchiveName & " " & Filename lngSize = Len(strOutPut) RC = Zip(hWnd, strCommand, strOutPut, lngSize) ■質問  ファイル名を毎回変えて繰り返し処理すればいいと考えてますが、  圧縮するファイルを指定するダイアログを消すことができません。。。  ファイル名を以下のように直接指定しましたが、以下エラーが出てしまいます。  VBAで取得したファイル名で圧縮するような記述の仕方があればご教示いただけると助かります! '★ファイル名取得★ Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls") If Filename = "False" Then Exit Sub   ↓以下に変更したがエラー  Filename = "C:\" & "test.xls" ←とりあえずファイル名を固定で指定したつもり。。  ●イミディエイトに表示されるエラー   zip warning: name not matched: test.xls   zip warning: test.zip not found or empty

  • ActiveWorkBook VBA

    Sub test() Dim myCSV As String Dim Fname As Variant Dim Aname As String Dim Fullp As String Application.ScreenUpdating = False Fullp = ActiveWorkbook.FullName Pos = InStrRev(Fullp, "\") Fname = Left(Fullp, Pos) myCSV = Dir(Fname & "*.csv") Do Until myCSV = "" Workbooks.Open Fname & myCSV Aname = Left(Fullp, InStr(1, Fullp, ".") - 1) ActiveWorkbook.SaveAs filename:=Aname & ".xls", FileFormat:=xlExcel9795 ActiveWorkbook.Close myCSV = Dir() Loop Kill Fname & "*.csv" End Sub あるフォルダにあるcsvファイルをxlsで保存したいと思いましたが、アクティブになるBOOKがバラバラ? で、うまくいきません。csvファイルを開いたときに そのファイルがアクティブになり、うまくloopできないでしょうか?

  • Excelシート1シートのみを指定フォルダへ保存

    Excelのシート1のみを、本日の日付と名前の入ったセル(I7)を保存する時の名前にして指定したフォルダへ保存したいと思っています。 1、シートは本日の日付+I7セルに入っている値を名前にする。 2、フォルダはCではなくV:\○○\○○\○○\○○\○○\○○\○○に格納 3、シート1以外のシート2、シート3は保存せず閉じる 4、格納後○○に保存しました。と表示 試行錯誤し、下記のように記述してみたのですが、 Sub Macro1() 'Option Explicit Sub Sample() Dim xSheet As Worksheet Dim myFile As String Dim myName As String Set xSheet = ActiveSheet ThisWorkbook.Worksheets("シート名").Copy 'myName = ActiveWorkbook.Worksheets(1).Name 'myFile = ThisWorkbook.Path & "\" & myName & ".xls" myFile = ThisWorkbook.Path & "\" & xSheet.Range("I7").Value & ".xls" Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=myFile Application.DisplayAlerts = True ActiveWorkbook.Close End Sub 日付を指定して保存 Sub test()  Dim Filename As String  Filename = Format(Date, "yyyy年mm月dd日") & ".xls"  ActiveWorkbook.SaveAs "C:\My Documents\" & Filename End Sub 日付とI7セルの名前を合せてブックの名前としたい場合どうVBEで記述すればいいのかわからないので詳しい方がおられましたら、 よろしくお願いいたします。 あまり詳しくないので、そのままコピーできるか、○○の部分を指定フォルダ名に変えてください。等の注釈を付けていただけると助かります。

  • vbaでファイルを開くパス名に変数を使いたい

    お世話になります。 下記の様にファイルを開く時のパス名に変数を使用したいのですが、 エラーがかかります。 ご教示頂けます様宜しくお願い致します、        記 Dim mywNm1 As String mywNm1 = Format(Now, "yyyymm") Workbooks.Open Filename:="C:\mywNm1_glp.xls", ReadOnly:=True

  • EXCELVBAでONEDRIVE上への保管方法 

    EXCEL ファイルの VBAで、 OneDrive上の ファイルを コピーして XLSX および XLS旧フォーマット 両方の 保存形式で ファイルを 保管しようとしています。 WINDOWS8.1 EXCEL2013 を 使用しています。 ONEDRIVE上へ、コピー作成する同名ファイルがなく、 新規のファイルを コピー作成する場合は 『Microsoft Excelは動作を停止しました。』 というエラーが (ファイルをコピー作成していますが)、 出てしまいます。 上書きする場合は エラー がでない模様です。 ' Sub 旧EXCEL形式保管() ' Application.DisplayAlerts = False ' Dim PathName, FileName1, FileName2, FileName3 As String ' PathName = ActiveWorkbook.Path FileName1 = "テスト.xlsx" FileName2 = "テストCOPY旧.xls" FileName3 = "テストCOPY新.xlsx" ' Workbooks.Open Trim(PathName) & "\" & Trim(FileName1) Windows(Trim(FileName1)).Activate ' ActiveWorkbook.SaveAs Filename:=Trim(PathName) & "\" & Trim(FileName3) ActiveWorkbook.Close ' Workbooks.Open Trim(PathName) & "\" & Trim(FileName1) Windows(Trim(FileName1)).Activate ' If Application.Version < 12 Then ActiveWorkbook.SaveAs Filename:=Trim(PathName) & "\" & Trim(FileName2), FileFormat:=xlExcel9795 Else ActiveWorkbook.SaveAs Filename:=Trim(PathName) & "\" & Trim(FileName2), FileFormat:=xlExcel8 End If ' ActiveWorkbook.Close ' End Sub ' より効率的な VBA記述、 エラーへの対処方法 を 教えていただけないでしょうか? よろしく お願いします。

  • エクセルVBAでパスの¥マークについて

    このマクロを記述したBOOKと同じフォルダー内にある、シート001.xls を開くマクロです。 同一フォルダーにあるのですから、このような記述になると思います。 Sub kakunin1() Workbooks.Open (ThisWorkbook.Path & "\" & "シート001.xls") End Sub しかし、以下の3つはすべてシート001.xls を開くことができました。 Sub kakunin2() Workbooks.Open (ThisWorkbook.Path & "\" & "\" & "シート001.xls") End Sub Sub kakunin3() Workbooks.Open (ThisWorkbook.Path & "\" & "\" & "\" & "シート001.xls") End Sub Sub kakunin4() Workbooks.Open (ThisWorkbook.Path & "\" & "\" & "\" & "\" & "\" & "\" & "シート001.xls") End Sub パスの¥マークは階層をあらわすのだと思っていましたがいくつ重ねてもなぜ開くのでしょうか?非常に初歩的な質問だと思いますが、ご教示いただければ幸いです。

  • excelのファイルとセル値を書き出したい

    excel2003を利用しています。 とあるフォルダにある excelファイル名(自分自身のファイルを除く) を全て書き出して、 且つ A1セルの値をB列に書き出すことを、やろうとvbaを作ってみましたが。 最後のファイルのA1セルを書きだすところで、エラーになっていまい そこだけ空白になってしまいます。※写真参照 記述は以下の通りです。どのように修正すればよいか 教えていただけないでしょうか? また他にもっと優れた記述があれば、そちらも教えて欲しいです。 よろしくお願いします。 Sub test() Dim buf As String, cnt As Long Dim Path As String Path = ThisWorkbook.Path & "\" buf = Dir(Path & "*.xls") cnt = 2 Do While buf <> "" If buf <> ThisWorkbook.Name Then cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Workbooks.Open Filename:=Path & "\" & buf MsgBox Workbooks(buf).Worksheets(1).Range("A1").Value Cells(cnt, 2) = Workbooks(buf).Worksheets(1).Range("A1").Value Workbooks(buf).Close End If Loop End Sub

  • 指定フォルダ内のファイルオープン→別フォルダに同じファイル名のcsvとして保存 のマクロを作ろうとしています

    エクセルで、指定フォルダ内のファイルオープン→別フォルダに同じファイル名のcsvとして保存 のマクロを作ろうとしています。 現在下記のようなマクロを途中まで作成したのですが、保存の良い方法が分からず困っております。 (ファイルオープンまでは出来ているようですが、その後エラーが出てしまいます) どなたかお知恵を拝借願えませんでしょうか。 どうぞ宜しくお願い致します。 Sub Book_Open() Dim BookName As String Dim PathName As String PathName = "C:\test_htmltocsv\test\" BookName = Dir(PathName & "*.html") Do Until BookName = "" Workbooks.Open PathName & BookName BookName = Dir() ActiveWorkbook.SaveAs "Sample.xls" ←← Loop End Sub

専門家に質問してみよう