[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Dir関数サブファイル含めて検索』（あべ）
Dir関数のサブファイルを含めた検索の書き方に悩んでおります。
ループ処理をしており、
処理する条件として、フォルダ内にブックが存在する場合のみ処理
と設定しているのですが、
ブックはフォルダの中かサブフォルダの中かはそれぞれです。
「If Dir(パス & "\" & fileName & ".xls*") <> "" Then」
上記１文を書き換えたいと思っています。
"fileName"にはワイルドカードを使用しているため、
Dir関数を使いたいのですが
下記等を参考にしてもうまく作れませんでした。
https://www.moug.net/tech/exvba/0060088.html
ご教授いただけますと幸いです。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
想像ですが、Dir関数"のみ"で再帰処理をしようとしており、２回目？のDir関数で、最初のDir関数がリセットされちゃって困ってるんじゃないでしょうか？
（もこな２ ） 2020/04/23(木) 01:49
https://www.moug.net/tech/exvba/0060088.html に少し手をいれたものです。参考までに。 A列にファイル名。 B列にフルパス名を出力します。
Option Explicit
Dim cnt As Long
Sub main()
Dim rootPath As String
cnt = 0
rootPath = "D:\MyDocuments\2020Excel\" ' ■要変更
Call Sample3(rootPath)
End Sub
Sub Sample3(path As String)
Dim buf As String, f As Object
buf = Dir(path & "\*.xls*")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, "A") = buf 'A列にファイル名
Cells(cnt, "B") = path & "\" & buf 'B列にパス
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(path).SubFolders
Call Sample3(f.path)
Next f
End With
End Sub
（γ） 2020/04/23(木) 02:20
突っ込むところは多々かと思いますが、
特に教えていただきたいのは、下記２点です。
１、ファイルが存在する場合のみ実行するとしたいのですが、
「Call Sample3(rootPath)」の後に何をかけばいいのでしょうか
２、ファイルを探して存在確認をするだけなのすが、
「Sub Sample3」の下記部分は必要なのでしょうか
cnt = cnt + 1
Cells(cnt, "A") = buf 'A列にファイル名
Cells(cnt, "B") = path & "\" & buf 'B列にパス
ご教授いただけますと幸いです。
Option Explicit
Dim cnt As Long Dim i As Long '変数が定義されていないとエラーが出たため追加
Sub main()
For i = 2 To Sheets("対象者").Range("A100000").End(xlUp).Row
'条件_A行目がaのみ転記
If (Range("A" & i)) = "a" Then
'既存の条件式_フォルダが存在する場合のみ実行
'If Dir(ThisWorkbook.path & "\" & fileName) <> "" Then
'上記１行を書き換えたいです
Dim rootPath As String
cnt = 0
rootPath = ThisWorkbook.path '■要変更"
Call Sample3(rootPath, "*" & Range("C"& i).Value & "*" & ".xls*")
'処理１
'処理２
'処理３
End IF
End IF
Next i
End Sub
Sub Sample3(path As String)
Dim buf As String, f As Object
'buf = Dir(path & "\*.xls*")
buf = Dir(path & "*" & Range("C"& i).Value & "*" & ".xls*")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, "A") = buf 'A列にファイル名 '?A
Cells(cnt, "B") = path & "\" & buf 'B列にパス
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(path).SubFolders
Call Sample3(f.path)
Next f
End With
End Sub
Option Explicit
Dim cnt As Long （あべ） 2020/04/23(木) 23:31
まず、実行したいことを日本語で箇条書きにしてください。
シートに既存の情報があるなら、その説明もしてください。
（γ） 2020/04/23(木) 23:57
処理したいことは、一覧から個々のシートへ転記作業です。
一覧.xlsmから指定したブックを開いて転記する処理を1000回繰り返します。
一覧.xlsm ___D___...__S_____ 1 名前 成績 2 山田 a ←「山田.xlsx」の「Sheet1」のA5セルに転記 3 田口 a ←「田口.xlsx」の「Sheet1」のA5セルに転記 4 千葉 c ←「千葉.xlsx」の「Sheet1」のA5セルに転記 5 羽柴 b ←「羽柴.xlsx」の「Sheet1」のA5セルに転記 6 羽生 b ←「羽生.xlsx」の「Sheet1」のA5セルに転記 7 上田 a ←「上田.xlsx」の「Sheet1」のA5セルに転記 : 1000
・一覧.xlsmのd列の名前のブックを開く(d列はブック名の一部)
・開いたブックのA5セルに一覧.xlsmのs列の値を転記
・開いたブックを保存して閉じる
・全員分実施
・D列の名前のブックは存在しない場合もある
・サブフォルダに格納されている場合もある
下記マクロは正常に実行できます。
ただ、5行目の下記1行をサブフォルダも含めて
存在確認をするようにしたかった次第です。
'条件_フォルダが存在する場合のみ実行
If Dir(ThisWorkbook.Path & "\" & "*" & Range("C" & i).Value & "*" & ".xls*") <> "" Then
どうぞ宜しくお願い致します。
Sub 練習
Dim wb1 As Workbook
'2行目から最終行まで繰り返し実行
For i = 2 To Sheets("対象者").Range("A100000").End(xlUp).Row
'G列の値が１のみ実行
If Range("G" & i).Value = "１" Then
'条件_フォルダが存在する場合のみ実行
If Dir(ThisWorkbook.Path & "\" & "*" & Range("C" & i).Value & "*" & ".xls*") <> "" Then
'指定のブックを開く（Workbooks.Openにワイルドカード使えないとのことで少し複雑）
Dim FILENAME As String
FILENAME = Dir(ThisWorkbook.Path & "\" & "*" & Range("C" & i).Value & "*" & ".xls*")
Workbooks.Open ThisWorkbook.Path & "\" & FILENAME
Set wb1 = ActiveWorkbook
'転記
wb1.Worksheets("Sheet1").Range("a5") = _
ThisWorkbook.Worksheets("一覧").Range("S" & i)
'マクロファイルを保存してブックを閉じる
wb1.Close SaveChanges:=True
End If
End If
Next i
End Sub
（あべ） 2020/04/24(金) 01:19
ThisWorkbookの保存されているフォルダの直下、 およびそのサブフォルダ（それのさらにサブフォルダ等々）を 対象にファイルを検索したい、というところがポイントの様子。
この場合、Dir("D:\AAA\*\*.xls*")のようにフォルダ部分にも
ワイルドカードを使うようなことはできません。
まず、 ThisWorkbookの保存されているフォルダ(仮にAフォルダとしましょう）の 下にあるフォルダはどういう構造になっているのでしょうか。
A - subB - subC - subD といった程度の構造なんでしょうか。
それとも、
A - subB
- subC - SubD
- SubE - SubF
などと階層も深く、たくさんのフォルダがあるんでしょうか。
延べのファイル数、フォルダの数、階層の深さについて 概略で結構なので教えてください。
私は、既に示したコードを使って、 いったんワークシートに、 ファイル名とフルパス名の一覧を書き出して、 それを検索したらどうかと思いますが(*)、 まずは、上記のことについて回答願います。
(*)勿論色んな方法があるとは思います。 ・Dirコマンドを標準出力で受けて、配下のフルパス名の配列を作成し、Filterで抽出する方法、 ・再帰処理のなかで、ファイルのBaseNameをキーに、フルパス名をItemとする辞書を予め作る方法 などがあるとは思います。一番理解し易いのはどれか考えたいと思っています。
（γ） 2020/04/24(金) 07:54
おおよそ下記の通りです。
延べのファイル数:1000
フォルダの数:30
階層の深さ:
():ファイル数
A - sub1(20)
- sub2(20)
- sub3(10)
- sub4(20)
- sub5(5)
- sub6(25)
- sub7(100)
- sub8(20)
- sub9(30)
- sub10(100)
- sub11(60)
- sub12(10)
- sub13 - sub13.1(5)
- sub13.2(30)
- sub13.3(25)
- sub13.5(10)
- sub13.6(50)
- sub14 - sub14.1(100)
- sub14.2(50)
- sub14.3(10)
- sub15(50)
- sub16(80)
- sub17(5)
- sub18(10)
- sub19(100)
- sub20 - sub20.1(20)
- sub20.2(100)
- sub20.3(5)
- sub20.5(25)
- sub20.6(10)
- sub21(80)
以上です。
いったん書き出す、なるほど！そうですね
１つにまとめようと必死でした
（あべ） 2020/04/24(金) 09:01
どうやら↓から話がずっと続いてるように思います。
[[20200416224751]] 『一覧から別々のファイルへ抽出をしたいです』（あべ）
[[20200421182145]] 『(Dir関数)ループ処理での存在しないファイルのスキップについて』（あべ）
ちょっと思ったのは、「無かったら処理しない」という風に仰ってますが「あったら処理する」って考えたほうがいいんじゃないかな～なんて思いました。
したがって
(1) ルートフォルダを指定する
(2) 再帰処理でファイル名が「山田.xlsx」と一致するものを探す (3) (2)で見つかれば、ブックを開いて処理して閉じる
(4) 再帰処理でファイル名が「田口.xlsx」と一致するものを探す (5) (4)で見つかれば、ブックを開いて処理して閉じる
・ ・ ・ ・
みたいなアプローチもあるのではないかと思います。
ちなみに、無いブックもあるということですが、逆にフォルダ群の中に同じファイル名のものが複数あったりはしないのでしょうか？
また、処理結果（ファイルが存在したかどうか）もどこかに出力したほうがユーザーに分かりやすいんじゃないでしょうか？
（もこな２ ） 2020/04/24(金) 10:09
そうです！続いております。
以前教えていただいた手順にて作らせていただきました。
その節もありがとうございました！！
「あったら処理する」につきましては、
[[20200421182145]]でもご指摘いただき訂正致しました！
（恐らく出来ているかと…）
フォルダ群の中に同じファイル名のものが複数はございません。
また、処理結果（ファイルが存在したかどうか）は、
処理が完了した際にセルを塗りつぶす指定をしました。
ご教授いただいたアプローチにて処理したいと思っております！
（あべ） 2020/04/24(金) 13:11
質問への回答ありがとうございました。 このファイル構造だと、再帰処理で情報を取得するのがよいかと思いました。
こんな感じではどうですか。 ＞再帰処理のなかで、ファイルのBaseNameをキーに、 ＞フルパス名をItemとする辞書を予め作る方法 だけを書きました。申し訳ないが、ここまでとさせてください。
Option Explicit
Dim dic As Object Dim fso As Object
Sub main()
Dim rootPath As String
Set dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
'' rootPath = "D:\MyDocuments\2020Excel\" ' テスト用
rootPath = ThisWorkbook.path '' 本番
'key:ファイル名（拡張子除き）,Item: フルパス名 からなる辞書(dictionary)を作成
Call getFiles(rootPath)
Call 各ブックへの書き込み処理
End Sub
Sub 各ブックへの書き込み処理()
Dim ws As Worksheet
Dim wb As Workbook
Dim filePath As String
Dim personName As String
Dim k As Long
Set ws = ThisWorkbook.Sheets("一覧") ' "対象者"シートとの差異が不明
For k = 2 To 3 '最初はいくつかで検証してください。
''For k = 2 To ws.Cells(Rows.count, "A").End(xlUp).Row '本番はこちら
If ws.Cells(k, "G").Value = 1 Then ' "１"から変更
personName = ws.Cells(k, "C").Value
If dic.Exists(personName) Then '氏名が登録済みであれば
filePath = dic(personName)
Set wb = Workbooks.Open(filePath)
'転記
wb.Worksheets("Sheet1").Range("A5").Value = ws.Cells(k, "S").Value
wb.Save
wb.Close False
Else
Debug.Print k & "行目:" & personName & "に対するファイル無し"
End If
End If
Next
End Sub
Sub getFiles(path As String)
Dim buf As String, f As Object, s As Object
Dim ext As String
Dim baseName As String
For Each f In fso.GetFolder(path).Files 'パス直下の各ファイルに対して
ext = fso.GetExtensionName(f.path) '拡張子
baseName = fso.GetBasename(f.path) '拡張子を除いたファイル名
If LCase(Left(ext, 3)) = "xls" Then 'Excelファイルなら
If dic.Exists(baseName) Then '同じ氏名の既登録データがあれば
Debug.Print "重複:"; f.path
Else
dic(baseName) = f.path '辞書に登録
End If
End If
Next
For Each s In fso.GetFolder(path).SubFolders 'パスの下のサブフォルダに対して
Call getFiles(s.path) '再帰実行
Next
End Sub
（γ） 2020/04/24(金) 21:12
Sub メイン処理()
Dim i As Long
Dim ルートフォルダ As String
Dim MyFolder As Object
Dim ファイルパス As String
'▼ダイアログでフォルダを指定する
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Set MyFolder = CreateObject("Scripting.FileSystemObject").GetFolder(.SelectedItems(1))
Else
Exit Sub
End If
End With
Stop
With ActiveSheet
For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
'▼「ファイルパス」を初期化してから
ファイルパス = ""
'▼「ファイルパス」は"参照渡し"でサブルーチンを呼び出す
Call サブルーチン(ファイルパス, MyFolder, "*" & .Cells(i, "D").Value & "*.xls?")
'▼「ファイルパス」に「""」以外が格納されているかで処理分岐
If ファイルパス <> "" Then
MsgBox ファイルパス & vbLf & "↑のブックを開いて処理する"
Else
MsgBox .Cells(i, "D").Value & " を含むファイルは存在せず"
End If
Next i
End With
End Sub
'===============================================================================
Sub サブルーチン(ByRef ファイルパス As String, ByVal MyFolder As Object, ByVal キーワード As String)
Dim ファイル As Object
Dim フォルダ As Object
Stop
For Each ファイル In MyFolder.Files
If ファイル.Name Like キーワード Then
ファイルパス = ファイル.Path
Exit For
End If
Next ファイル
Stop
If ファイルパス <> "" Then Exit Sub
For Each フォルダ In MyFolder.SubFolders
Call サブルーチン(ファイルパス, フォルダ, キーワード)
Next
End Sub
興味があればステップ実行して研究の上、理解してから、必要な部分のみ、ご自身のコードに取り込んでみてください。（理解していただきたいので、分からないまま丸写しはNGとします）
（もこな２ ） 2020/04/25(土) 11:30
私の方法だと、毎回アタマから検索することになるので、実行速度は速くないです。
したがって、実行速度が気になるようであれば、γさんのように検索自体を減らすようにしないとダメですね。
（もこな２ ） 2020/04/25(土) 11:57
>・Dirコマンドを標準出力で受けて、配下のフルパス名の配列を作成し、Filterで抽出する方法、
Sub test()
Dim wb As Workbook
Dim p As String
Dim cmd As String
Dim ss, s
Dim c As Range
Application.ScreenUpdating = False
p = ThisWorkbook.path & "\*.xlsx"
cmd = "cmd /c dir """ & p & """ /b/s/a-d"
ss = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
For Each c In Sheets("一覧").Range("C2:C3000").SpecialCells(xlCellTypeConstants)
If c.EntireRow.Range("G1").Value = 1 Then
s = Filter(ss, "\" & c.Value & ".xlsx")
If UBound(s) >= 0 Then
Set wb = Workbooks.Open(s(0))
wb.Sheets("Sheet1").Range("A5").Value = c.EntireRow.Range("S1").Value
wb.Close True
End If
End If
Next
End Sub
＞フォルダ群の中に同じファイル名のものが複数はございません。
が前提です。
試してませんが、1000ファイルもあると、それなり時間はかかると思います。
（マナ） 2020/04/25(土) 18:27
もこな2さんのコードを拝見しました。
今のままですと、 例えば、質問者さんの示されたフォルダ構造で言えば sub1の配下でマッチしたとしても、 その兄弟フォルダである、sub2以下のファイルたちを、 （この例ではないですが、親フォルダの兄弟フォルダのファイルたちも） 延々と調べてしまうので、効率を上げるためになんらかの対応が必要でしょうか。
(1) サブルーチンに入って直ぐのところにも、 If ファイルパス <> "" Then Exit Sub を入れてしまうか、 (2) 見つかった段階でErr.Raiseを発生させて、特定ラインにジャンプさせ、 大域ジャンプの代わりにするんでしょうか。
癖のようなものでついつい細かいところが気になりますが、 "富豪的プログラミング"という言葉があるように、 そういったことはマシン能力でカバーするんだ、というのも整理の仕方として あるんでしょうね。余談めいた話で恐縮でした。
追伸： マナさん、フォローありがとうございます。 この間マナさんに教えていただいたものを知ったかぶりしてしまいましたww。 （γ） 2020/04/25(土) 21:30
（１）の亜種で、
Sub サブルーチン(ByRef ファイルパス As String, ByVal MyFolder As Object, ByVal キーワード As String)
Dim ファイル As Object
Dim フォルダ As Object
For Each ファイル In MyFolder.Files
If ファイル.Name Like キーワード Then
ファイルパス = ファイル.Path
Exit For
End If
Next ファイル
If ファイルパス <> "" Then Exit Sub
For Each フォルダ In MyFolder.SubFolders
Call サブルーチン(ファイルパス, フォルダ, キーワード)
If ファイルパス <> "" Then Exit For
Next
End Sub
みたいに、呼び出したサブルーチンで見つかっていたらループを抜けるというのはどうですかね。
（もこな２ ） 2020/04/25(土) 21:55
ところで、私の当初の案ですが、
氏名 それに対するファイルのパス 山田 D:\AAA\Sub1\山田.xlsx ・・・ ・・・・ のような表は、これに限らず、色々な用途で使えるものではないでしょうか。 これを使えば、VLOOKUPでパスも得られますし、 ひとつは持っておくべき表ではないでしょうか。 というより、今までどうやって管理していたんだろう、という気がします。
基本的なところから道具を揃えていくのがよいのではないでしょうか。
私は本当にここで失礼します。
（γ） 2020/04/25(土) 22:40
>呼び出したサブルーチンで見つかっていたらループを抜けるというのはどうですかね。 後出しですみませんが、プロシジャを抜ければ、IF文省略できます。 が、やっぱり、ファイル数が多いと時間はかかりますね
Sub sample()
Dim Path As String, filename As String
Dim FSO As Object, Fld As Object
Path = "D:\work"
filename = "テスト.xls*"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fld = FSO.GetFolder(Path)
If FindFile(Fld, filename) Then
Debug.Print filename
End If
End Sub
Function FindFile(FolderOject As Object, ByRef filename As String) As Boolean
Dim f As Object
For Each f In FolderOject.Files
If f.Name Like filename Then
filename = f.Path
FindFile = True
Exit Function
End If
Next
For Each f In FolderOject.SubFolders
If FindFile(f, filename) Then
FindFile = True
Exit Function
End If
Next
End Function
（´・ω・`） 2020/04/26(日) 07:50
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.