• 締切済み

初心者のExcel2003VBA　フォルダの質問

_Kyleの回答

  • _Kyle
  • ベストアンサー率78% (109/139)
回答No.1

前回回答した者です。 今一つ状況を把握できていないので 補足要求のようになってしまいますが…。 ----------------------------- ◆１ 前回は 「あらかじめシート上に列挙されたパス一覧から前方一致検索して転記」 でしたが、 今回は 「直接ディレクトリを検索してフォルダのパスを取得し新規フォルダにコピー」 ということでしょうか？ 今回、bシートのことは忘れてもOK？ ----------------------------- ◆２ 「ID番号を含む名前のついたフォルダ」のフォルダ名は 前回bシートのID列にあった 　B1234_ABC-TOUKYOUTONAKANOKU 　12345_DEF-TOUKYOUTOTOSHIMAKU といったものと同様の形式でしょうか？ もしそうでないならば、差し支えの無い範囲でサンプルを。 　※単純に「"1234"を含む」で検索すると 　　B1234_ABC-TOUKYOUTONAKANOKU　だけでなく 　　12345_DEF-TOUKYOUTOTOSHIMAKU　や 　　912345_FED-TOUKYOUTONAKANOKU　もヒットしてしまいますから 　　ID番号の始まりと終わりの位置を判断する条件が必要です。 ----------------------------- ◆３ 「ID番号を含む名前のついたフォルダ」は 「日付毎に作成されたサブフォルダ」のすぐ下にあるのでしょうか それともサブフォルダのさらにサブフォルダに…ということもあるのでしょうか？ ----------------------------- ◆４ 検索する際 ・複数のフォルダがヒットする可能性は？ ・複数ヒットした場合の処理は？ ・フォルダではなくファイルがヒットする可能性は？ ・ファイルがヒットした場合の処理は？ ----------------------------- ◆５ >欲しいフォルダには下位フォルダとして、 >zipフォルダも含まれる(この中のデータが欲しい時もあり) とのことですが zipフォルダの内部を検索する必要があるのですか？ それとも単に、 「ID番号を含む名前のついたフォルダ」の内部に zipフォルダがあるということですか？ ======================================================== 補足要求だけというのもなんなので 一応コードも書いてみましたが…。 動作の概要 　ID番号の桁数に応じて、カテゴリフォルダ1 または カテゴリフォルダ2 を選び 　その【２つ下の階層】（「日付毎に作成されたサブフォルダ」の直下）について 　前回bシートID列にあったのと同じ形式の名前のフォルダを検索し 　ヒットすれば、前回パスを書き込んだ列の【右隣の列】にパスを表示する 　複数ヒットした場合は上書きする '-----↓ココカラ↓--------------------------------- 　'【前略】 　'■宣言追加 　Dim ctFld As Folder 　Dim dtFld As Folder 　Dim tgFld As Folder 　'【中略】 　'■検索・コピペ 　For i = 1 To ipCnt 　　tpStr = ipAry(i) & "_*" 　　For j = idCnt To 1 Step -1 　　　If idAry(j) Like tpStr Then 　　　　lkRng.Cells(j, 1).Copy 　　　　rtRng.Cells(i, 1).PasteSpecial Paste:=xlPasteValues 　　　　Exit For 　　　End If 　　Next j 　　 　　Select Case Len(ipAry(i)) 　　　Case 4 　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ1へのパス」") 　　　　tpStr = "B" & tpStr 　　　Case 5 　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ1へのパス」") 　　　Case Is > 5 　　　　Set ctFld = FSO.GetFolder("「カテゴリフォルダ2へのパス」") 　　End Select 　　　　 　　For Each dtFld In ctFld.SubFolders 　　　For Each tgFld In dtFld.SubFolders 　　　　If tgFld.Name Like tpStr Then 　　　　　MsgBox tgFld.Path 　　　　　rtRng.Cells(i, 2).Value = tgFld.Path 　　　　End If 　　　Next tgFld 　　Next dtFld 　　 　Next i 　'■終了 　Set FSO = Nothing 　If Not ckFlg Then dtBok.Close 　Application.Calculation = xlCalculationAutomatic 　 End Sub '-----↑ココマデ↑---------------------------------

画像を拡大する
nazoiman
質問者

お礼

質問箱では何度も相談に乗っていただきありがとうございました 8月末に2度目の質問をした後急遽出張が決まってしまい アカパスを会社に残したまま出てしまったので ログインが出来ずアクションが起こせませんでした ようやく出張が終わり今月から戻ってきて また改めてVBAに着手できるようになりました 2度目の質問に対する回答、ありがとうございます 参考にさせてもらい、取り組んでいきます もし寛大なお心で見守っていただけるのであれば また相談に乗っていただけたらと思います ありがとうございました＞＜

nazoiman
質問者

補足

ちなみにというか、不躾で申し訳ありませんが お勧めのVBA教本のような参考書のような、そんなものありましたら そちらも併せて教えて頂けたりすると嬉しいです＞＜ よろしくお願いします。

この回答がついた質問に戻る
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • vbsスクリプトについて

    いつもありがとうございます。 実行するVBSファイルのカレントディレクトリを取得して、同じディレクトリにAフォルダがなければ Aフォルダを作成するといった下記処理を考えております。 Set objFSO = CreateObject("Scripting.FileSystemObject") If objFSO.FolderExists(Path) = True Then objFSO.DeleteFolder (Path) objFSO.CreateFolder (Path) Else objFSO.CreateFolder (Path) End If Pathの変数にAフォルダまでのフルパスを入れたいのですが 実現できるソースをアドバイスいただけませんでしょうか。 Path = objFSO.CreateFolder (".\A") でパスは取得できるのですが、フォルダの存在チェックの前にフォルダが作られるため だめでした。。 宜しくお願い致します。

  • VBSでフォルダ、ファイル作成時のエラーコード

    フォルダ、ファイルが存在しないとき、作成するスクリプトをVBSで作成していますが、疑問点があるのでご教示ください。 objFSO.CreateFolder、objFSO.CreateTextFileを実行が、正常に行われた場合、 Err.Numberに0がセットされると思っていましたが、実際は違っていました。 objFSO.CreateFolderでフォルダが作成される場合、Err.Numberに13が返されます。 objFSO.CreateTextFileでファイルが作成される場合、Err.Numberに438が返されます。 このスクリプトを実行後、フォルダ、ファイルが存在しない場合、作成されることも確認しています。 フォルダ作成後、作成されたフォルダに対して、ファイルの作成／データの書き込みのアクセス権を拒否にすると返されるErr.numberに70がセットされることも確認しています。 なぜ、フォルダ、ファイルが作成された場合、0が返されないのかご存知の方がいらっしゃいましたらご教示ください。 また、その情報が記載されている書籍およびサイトがあれば、お教えいただければ、幸いです。 Option Explicit Dim objFSO Dim objFile Const strFolderName = "C:\VBS" Const strFileName = "C:\VBS\test.txt" On Error Resume Next Set objFSO = CreateObject("Scripting.FileSystemObject") If Err.Number = 0 Then WScript.Echo "FSOオブジェクトを作成しました" Else WScript.Echo "FSOオブジェクトを作成できませんでした" WScript.Quit(1) End If If objFSO.FolderExists(strFolderName) Then WScript.Echo "フォルダが見つかりました" Else WScript.Echo "フォルダが見つかりませんでした" If objFSO.CreateFolder(strFolderName) Then If Err.Number = 13 Then WScript.Echo "フォルダを作成しました" Else WScript.Echo "フォルダを作成できませんでした" WScript.Quit(1) End If End If End If If objFSO.FileExists(strFileName) Then WScript.Echo "ファイルが見つかりました" Else Script.Echo "ファイルが見つかりませんでした" If objFSO.CreateTextFile(strFileName) Then If Err.number = 438 Then WScript.Echo "ファイルを作成しました" Else WScript.Echo "ファイルを作成できませんでした" WScript.Quit(1) End If End If End If

  • vbaで新規フォルダ作成時の名前の指定

    「あいいうえお」フォルダの中に年が変わったら「2015年」という名前でフォルダの作成を行いたいのですが、下記のコードでは「あいうえお2015年」という名前のフォルダを作成してしまいます。フォルダの作成で、「あいうえお」を除いたものを作成するにはどう変えればよいでしょうか？ （12月のファイルで実行した時に例えば「2015年」フォルダを作成して、その中に「あいうえお2015-1月.xlsm]ファイルを作成します。同じ年なら「あいうえお11月.xlsm]などファイルのみを作成します。） お手数をおかけしますがどうぞよろしくお願いいたします。 Sub ブックコピー自動翌月分作成() Dim i As Integer Dim wb As Workbook Dim myDir_path As String, myNew_path As String 'フォルダパスとファイルパスを作成 myDir_path = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1) myNew_path = "あいうえお" & Format(DateAdd("m", 1, Replace(Replace(ThisWorkbook.Name, "あいうえお", ""), "月.xlsm", "")), "yyyy-m") & "月.xlsm" myDir_path = Left(myDir_path, InStrRev(myDir_path, "\")) & Left(myNew_path, 9) & "年\" 'フォルダの有無を確認、なければ作成 With CreateObject("Scripting.FileSystemObject") If Not .FolderExists(myDir_path) Then MkDir myDir_path 'MsgBox myDir_path & "を作成しました" 'MsgBox Left(myDir_path, InStrRev(myDir_path, "\")) & "に" & vbNewLine & MsgBox Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 12) & "に" & vbNewLine & _ Left(myNew_path, 9) & "年" & "フォルダを新たに作成しました" End If End With 'ファイルの有無を確認、なければ保存,あれば処理中止 If Dir(myDir_path & myNew_path) = "" Then ThisWorkbook.SaveCopyAs myDir_path & myNew_path MsgBox myNew_path & "のファイルを新たに作成しました" Else MsgBox "翌月分のファイルはすでに存在するので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If '新規作成したブックを開く,既に開いていれば処理中止 For Each wb In Workbooks If wb.Name = myNew_path Then MsgBox myNew_path & "は既に開いているので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If Next Workbooks.Open myDir_path & myNew_path Workbooks(myNew_path).Activate End Sub

  • VBAによるカレントフォルダのファイルを検索し開く

    カレントフォルダ内にファイル(コ―ド.xls)を見つけ開き、無ければＭＳＧ表示したい。 どのように、したらいいですか？ 考えているのは、 Application.DefaultFilePath = ThisWorkbook.Path If ??? Then Workbooks.Open "コード.xls" else msgbox (ThisWorkbook.Path & "にコード.xlsを置いて下さい。") Exit sub end If です。 この？？？の部分を教えて頂きたいと思います。 よろしくお願いします。

  • VBAでの疑問

    以下のようなコードを見ました。 Private Sub Workbook_BeforeClose(Cancel As Boolean) With ThisWorkbook Application.DisplayAlerts = False If .Name <> .FullName Then SaveAs Else Me.Saved = True End If Application.DisplayAlerts = True End With End Sub これは何のためのコードでしょうか？ If .Name <> .FullName Then　って、パスなしのBOOK名とパス付BOOK名が同じじゃないのは当然で、同じになるのは新規に作成したばかりで保存する前のファイルくらいしか思いつきません。これでは必ず上書きされてしまうと思いますが、どういう意図が考えられるのかお分かりの方教えていただけないでしょうか？

  • Excel VBAでのSaveCopyAsの挙動

    Excel 2016/2019を使っています。よろしくお願いします。 ブックに変更があった場合にバックアップを保存したいので、 上書きにならないように日付と連番をつけてバックアップ専用フォルダにSaveCopyAsを使って保存しようとしています。 明示的に「保存」アイコンをクリックすると期待通りの動作が行われます。しかし、保存せずに「x」印をクリックして閉じてしまった場合でも、変更があるならバックアップファイルを作りたいのですが、SaveCopyAsを通っているのにバックアップファイルが作成されません。 記載したコードは以下のとおりです。 ThisWorkbookオブジェクトに対して、 Public Sub Workbook_beforeClose(Cancel As Boolean) '変更があれば（ThisWorkBookを）保存 If ThisWorkBook.Saved = False Then ThisWorkBook.Save End If End Sub 'ThisWorkBookの保存時にバックアップを作成 Private Sub Workbook_BeforeSave(省略) If ThisWorkbook.Saved = False Then 'バックアップファイルのフルパスを作成 　ThisWorkbook.SaveCopyAs "バックアップファイルフルパス" End Sub 何かヒントをお持ちの方みえられましたらご教示いただければ幸いです。

  • EXCEL2000 フォルダ内のファイルを検索

    EXCEL2000 フォルダ内のファイルを検索 お分かりになる方がいましたらお力添えの程よろしくお願いします。 任意のフォルダ内で任意のファイルサーチが出来るマクロを実行したいのですが、ファイルサーチの値を全角、半角、大文字、小文字区別なく行いたいのです。 例えば,セル2,2に、topと入力したら、topもｔｏｐもTOPもＴＯＰも検索対象に引っかかり、セルに書き出して欲しいのです。 ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub ファイル一覧2() Dim vntF As Variant Dim objFS As FileSearch Dim objFSO As FileSystemObject Dim GYO As Long Dim cntFound As Long Set objFS = Application.FileSearch ' FileSearch Set objFSO = New FileSystemObject ' FSO Rows("5:65536").ClearContents Application.ScreenUpdating = False GYO = 4 With objFS .NewSearch .LookIn = Trim(Cells(1, 2).Value) ' Search開始フォルダ .Filename = Trim(Cells(2, 2).Value) ' 探索ファイル式 .SearchSubFolders = True ' サブフォルダも探索 ' 処理開始 If .Execute() <> 0 Then For Each vntF In .FoundFiles With objFSO.GetFile(vntF) GYO = GYO + 1 Cells(GYO, 1).Value = .Name Cells(GYO, 2).Value = .DateLastModified Cells(GYO, 3).Value = _ Left(.Path, Len(.Path) - Len(.Name) - 1) cntFound = cntFound + 1 End With Next vntF End If End With Set objFS = Nothing Set objFSO = Nothing ' 処理結果の表示 If cntFound = 0 Then MsgBox "見つかりません" Else MsgBox cntFound & "個見つかりました" End If End Sub

  • VBAでフォルダ内の全てのｃｓｖファイルからコピペ

    マクロ超初心者です。 フォルダ内のすべてのｃｖｓファイル（５００程度）の5列目（500行程度）を新規ファイルの1列目から順にコピーしていきたいのです。 ちなみに元のｃｖｓファイルのシート数は一つだけでシート名には全てファイル名が付いています。 （つまり全てのファイルのシート名が異なる） 見よう見真似で似たようなマクロから意味もわからないまま つぎはぎして下記作りましたが やっぱり動きません。 どなたか詳しい方どうかよろしくお願いします。 Sub Sample() Const FolderPath As String = "C:\data" Dim objFSO As Object Dim objBook As Object Dim lngRow As Long Application.ScreenUpdating = False Set objFSO = CreateObject("Scripting.FileSystemObject") For Each objBook In objFSO.GetFolder(FolderPath).Files lngcolumn = ThisWorkbook.Sheets("sheet1").Range("A" & Columns.Count).End(xlToRight).Column + 1 Workbooks.Open objBook.Path With ActiveWorkbook .Worksheets(1).Column("5").Copy ThisWorkbook.Sheets("sheet1").End(xlToRight).Offset(0, 1) .Close End With Next Set objFSO = Nothing Application.ScreenUpdating = True End Sub

  • VBAの質問です。

    VBAの質問です。 以下のプログラムで、４列おきにコピーしたい時はどうすればいいでしょうか？ １つのフォルダの中に集約第１期・集約第２期・集約第３期という名前の３つのファイルがあり、 その３つのファイル全てに「結果」というシートがあります。 この「結果」シートのC4:AU37の数値をコピーします。 コピーした数値を、集約第３期のファイルの中にある「集計用シート」のC2から貼り付けしていきたいのですが、 この時に、４列おきにはりつけたいと思っています。 集約第１期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C２の列から４列おきに 集約第２期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C３の列から４列おきに 集約第３期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C４の列から４列おきに といった具合です。 集約第３期ファイル-集計用シート-C５の列は空白し、C６からまた貼り付けます。 どこをどう直せば良いでしょうか？ Sub データ抽出() Dim i As Long Dim flg As Boolean Dim myWb As Workbook Dim myWbName As String Application.ScreenUpdating = False ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path ThisWorkbook.Worksheets("集計用シート").Range("C2:EG35").Clear For i = 1 To 3 flg = False myWbName = "集約第" & i & "期.xls" If myWbName <> ThisWorkbook.Name Then For Each myWb In Workbooks If myWb.Name = myWbName Then flg = True Next myWb If flg = False Then Workbooks.Open Filename:=myWbName Else Workbooks(myWbName).Activate MsgBox myWbName & "を閉じてから再実行してください。" Exit Sub End If End If Worksheets("結果").Range("C4:AU37").Copy ThisWorkbook.Worksheets("集計用シート").Range("C2").Offset(, 45 * (i - 1)).PasteSpecial Paste:=xlPasteValues If myWbName <> ThisWorkbook.Name Then Application.DisplayAlerts = False Workbooks(myWbName).Close SaveChanges:=False Application.DisplayAlerts = True End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

  • VBAでのサブフォルダ内のエクセル集約について

    VBAを使って所定のフォルダ内のデータを集計するプログラムをネットで調べ、 以下のように作ってみたのですが、 サブフォルダ内のデータも同じように集計することはできないでしょうか？ 以下のプログラムは正常に機能していて、「データフォルダ」直下にあるエクセルは 集計できています。 ※「データフォルダ」内に、都道府県別のフォルダが用意され、その中に市区町村別のエクセルが配置されている感じです。 ※EXCEL2013環境です。 Sub 全国集計() Const FolderPath As String = "\\C:\データフォルダ" Application.ScreenUpdating = False Range("6:1048576").Delete Dim objFSO As Object Dim objBook As Object Dim lngRow As Long Set objFSO = CreateObject("Scripting.FileSystemObject") For Each objBook In objFSO.GetFolder(FolderPath).Files lngRow = ThisWorkbook.Sheets("data").Range("A" & Rows.Count).End(xlUp).Row + 1 Workbooks.Open objBook.Path With ActiveWorkbook .Sheets("data").Rows("5:105").Copy ThisWorkbook.Sheets("data").Rows(lngRow) .Close End With Next Set objFSO = Nothing ActiveWindow.ScrollRow = 1 ActiveWindow.ActiveSheet.Range("A1").Select Application.ScreenUpdating = True End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する
質問する