Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10283 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【22592】Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 14:39 質問[未読]
【22594】Re:Dir関数でサブフォルダまでファイル検索 MMX 05/2/24(木) 15:06 発言[未読]
【22596】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/24(木) 15:47 発言[未読]
【22602】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 18:34 質問[未読]
【22610】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 19:35 質問[未読]
【22613】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/24(木) 19:46 発言[未読]
【22615】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 19:57 質問[未読]
【22617】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/24(木) 20:24 発言[未読]
【22620】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 21:48 質問[未読]
【22622】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/24(木) 22:06 発言[未読]
【22628】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/24(木) 22:48 質問[未読]
【22630】Re:Dir関数でサブフォルダまでファイル検索 ichinose 05/2/24(木) 22:57 発言[未読]
【22632】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/24(木) 23:19 発言[未読]
【22641】Re:Dir関数でサブフォルダまでファイル検索 MMX 05/2/25(金) 10:17 お礼[未読]
【22642】Re:Dir関数でサブフォルダまでファイル検索 でれすけ 05/2/25(金) 10:31 発言[未読]
【22646】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/25(金) 12:02 お礼[未読]
【22681】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/28(月) 1:12 質問[未読]
【22682】Re:Dir関数でサブフォルダまでファイル検索 ちゃっぴ 05/2/28(月) 1:21 発言[未読]
【22683】Re:Dir関数でサブフォルダまでファイル検索 でれすけ 05/2/28(月) 1:28 回答[未読]
【22689】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/28(月) 13:27 発言[未読]
【22691】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/28(月) 15:11 質問[未読]
【22693】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/28(月) 18:09 発言[未読]
【22694】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/28(月) 18:13 発言[未読]
【22700】Re:Dir関数でサブフォルダまでファイル検索 桜 05/2/28(月) 20:13 質問[未読]
【22704】Re:Dir関数でサブフォルダまでファイル検索 kazu 05/2/28(月) 21:43 発言[未読]
【22705】Re:Dir関数でサブフォルダまでファイル検索 イオン 05/2/28(月) 21:48 お礼[未読]
【22722】Re:Dir関数でサブフォルダまでファイル検索 桜 05/3/1(火) 10:18 お礼[未読]
【22592】Dir関数でサブフォルダまでファイル検索
質問  桜  - 05/2/24(木) 14:39 -
引用なし
パスワード
   こんにちは。

Dir関数でサブフォルダまでファイル検索する方法を
教えていただきたいのですが。

作成しているマクロは”C:\test”フォルダ内（サブフォルダ含む）配下の”表”を含むエクセルファイルを検索して　シートVer5.0がある場合に処理（セルに文字を入力）する
というものです。下記のコードですと、”C:\test”直下のファイルは検索できるのですがサブフォルダ配下までは検索できません。。
どなたか良い方法をご教授いただけるようお願いいたします。


Sub test()

　　Dim Mydir As String
　　Dim Filename As String
　　Dim mySh As String
　　Dim a As String
　　Dim myRng As Range
　　Dim i As Long
　　Dim n, ShtName, Flg
　　　　
　　　　　　
　　　　　　Mydir = "C:\test\"
　　　　　　'ファイル名を指定
　　　　　　Filename = Dir(Mydir & "\" & "*表.xls", VBnomal)
　　　　　　
　　　　　　Do While Filename <> ""
　　　　　　
　　　　　　'ファイルを開く
　　　　　　Workbooks.Open "C:\test\" & "\" & "*表.xls"
　　　　　　
　　　　　　　'シートの有無を確認
　　　　　　　
　　　　　　　ShtName = "Ver5.0"
　　　　　　　ShtName = "ver5.0"
　　　　　　
　　　　　　　 Flg = True
　　　　　　
　　　　　　　For n = 1 To Worksheets.Count
　　　　　　　　　If Worksheets(n).Name = ShtName Then
　　　　　　　　　　Flg = False
　　　　　　　　　　Exit For
　　　　　　　　 End If
　　　　　　　Next n
　　　　　　　
　　　　　　　　'シートVer5.0がある場合
　　　　　　　　If Flg = False Then
　　　　　　　　
　　　　　　　　　 'MsgBox ShtName & "は存在します。"
　　　　　　　　　
　　　　　　　　　　 'シートを選択
　　　　　　　　　　With Sheets("Ver5.0")


　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　
　　　　　　　　　　End With
　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　Workbooks(Filename).Save
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　'シートVer5.0がない場合
　　　　　　　　Else
　　　　　　　　　　
　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　End If


　　　　　'End If
　　　　
　　　　　Filename = Dir()
　　　　Loop
　　　　　　　　　
End Sub
【22594】Re:Dir関数でサブフォルダまでファイル検...
発言  MMX  - 05/2/24(木) 15:06 -
引用なし
パスワード
   >Dir関数でサブフォルダまでファイル検索する方法を
>教えていただきたいのですが。

ご質問の件主旨とは違いますが、
以前、以下のような「必要なフォルダが存在するかを確認する」
という処理を作ったことがあり、散々調べた結果、

Dim FSO　As Object 'FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")

なんてな記述を追加して

If False = FSO.FolderExists(ThisWorkbook.Path & "\" & Fold) Then

とういう方法で存在確認をしたことがあります。
この辺を応用して、検索対象下のフォルダを一旦リスト化してから
再度、お手元のソースで調べてみるというのはいかがでしょう？


十分な対応ができませんが、ご参考までに。

'------------------------------------------------------------
Function FolderExistenceChecker(Fold As String) As Integer
'---保存先フォルダの存在確認
'---（フォルダ名＝Fold）存在すれば０、存在しなければ１を返す。
'---
FolderExistenceChecker = 1
'---
Dim FSO　As Object 'FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")

'---フォルダ存在確認
If False = FSO.FolderExists(ThisWorkbook.Path & "\" & Fold) Then
　 MsgBox("【警告】フォルダが存在しません。")
Else
　 FolderExistenceChecker = 0
End If
'---
Set FSO = Nothing
'---
End Function
【22596】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 15:47 -
引用なし
パスワード
   桜 さん

こんにちは。


Fsoでいいのであれば・・・

　　Set Myfso = CreateObject("Scripting.FileSystemObject")
　　Set Sub_Fld = Myfso.GetFolder("C:\").SubFolders

でサブフォルダが取得できますよ。
（例ではC直下のｻﾌﾞﾌｫﾙﾀﾞを取得する様にしています。　GetFolder("C:\")　←　C:\　を検索したいフォルダ名にすればOK）
【22602】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/24(木) 18:34 -
引用なし
パスワード
   ▼kazu さん：

ありがとうございます。
下記はサブフォルダが複数ある場合にも使用可能でしょうか？
質問ばかりで恐縮ですがよろしくお願いいたします。

>桜 さん
>
>こんにちは。
>
>
>Fsoでいいのであれば・・・
>
>　　Set Myfso = CreateObject("Scripting.FileSystemObject")
>　　Set Sub_Fld = Myfso.GetFolder("C:\").SubFolders
>
>でサブフォルダが取得できますよ。
>（例ではC直下のｻﾌﾞﾌｫﾙﾀﾞを取得する様にしています。　GetFolder("C:\")　←　C:\　を検索したいフォルダ名にすればOK）
【22610】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/24(木) 19:35 -
引用なし
パスワード
   ▼kazu さん：

度々、恐縮ですが、FsoとDiｒ関数を組み合わせて
使用することは可能なのでしょうか？
【22613】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 19:46 -
引用なし
パスワード
   桜 さん

>度々、恐縮ですが、FsoとDiｒ関数を組み合わせて
>使用することは可能なのでしょうか？
↑　可能ですよ。

下記はサブフォルダが複数ある場合にも使用可能でしょうか？
↑　も可能です。配列として格納されます。
【22615】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/24(木) 19:57 -
引用なし
パスワード
   ▼kazu さん：

ありがとうございます。
Sfoについては全く知識がないので恐縮ですが
下記のようにコードに追加してみたけれど
うまく動作しません。。。。　ファイルがみつかりませんとなってしまいます。。
（今まではサブフォルダ以外は処理できていたのですが）

どこか不足があるのでしょうか。。
恐縮ですがご教授お願いいたします。

Sub test()

　　Dim Mydir As String
　　Dim Filename As String
　　Dim mySh As String
　　Dim a As String
　　Dim myRng As Range
　　Dim i As Long
　　Dim n, ShtName, Flg
　　　　
　　　　　　
　　　　　　Set Myfso = CreateObject("Scripting.FileSystemObject")
　　　　　　Set Sub_Fld = Myfso.GetFolder("C:\test\").SubFolders
　　　　　
　　　　　　'ファイル名を指定
　　　　　　Filename = Dir("C:\test" & "\" & "*表.xls", VBnomal)
　　　　　　
　　　　　　Do While Filename <> ""
　　　　　　
　　　　　　'ファイルを開く
　　　　　　Workbooks.Open "C:\test\" & "\" & "*表.xls"
　　　　　　
　　　　　　　'シートの有無を確認
　　　　　　　
　　　　　　　ShtName = "Ver5.0"
　　　　　　　ShtName = "ver5.0"
　　　　　　
　　　　　　　 Flg = True
　　　　　　
　　　　　　　For n = 1 To Worksheets.Count
　　　　　　　　　If Worksheets(n).Name = ShtName Then
　　　　　　　　　　Flg = False
　　　　　　　　　　Exit For
　　　　　　　　 End If
　　　　　　　Next n
　　　　　　　
　　　　　　　　'シートVer5.0がある場合
　　　　　　　　If Flg = False Then
　　　　　　　　
　　　　　　　　　 'MsgBox ShtName & "は存在します。"
　　　　　　　　　
　　　　　　　　　　 'シートを選択
　　　　　　　　　　With Sheets("Ver5.0")


　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　
　　　　　　　　　　End With
　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　Workbooks(Filename).Save
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　'シートVer5.0がない場合
　　　　　　　　Else
　　　　　　　　　　
　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　End If


　　　　　'End If
　　　　
　　　　　Filename = Dir()
　　　　Loop
　　　　　　　　　
End Sub
【22617】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 20:24 -
引用なし
パスワード
   ▼桜 さん：

こんばんは。

ちょろっと組替えてみました。
これで思っている通りの動作しますか？

Sub test()

　　Dim Mydir As String
　　Dim Filename As String
　　Dim mySh As String
　　Dim a As String
　　Dim myRng As Range
　　Dim i As Long
　　Dim n, ShtName, Flg
　　Dim AryFld()
　　
　　　　　　Set Myfso = CreateObject("Scripting.FileSystemObject")
　　　　　　Set Sub_Fld = Myfso.GetFolder("C:\test").SubFolders
　　　　　　Redim Preserve AryFld(Sub_Fld.Count)
　　　　　　n = 1　　　　
　　　　　　ReDim AryFld(Sub_Fld.Count)
　　　　　　AryFld(0) = "C:\test"
　　　　　　n = 1　　　　
　　　　　　For Each Fld In Sub_Fld
　　　　　　 AryFld(N) = Fld.Path
　　　　　　 n = n + 1
　　　　　　Next
　　　　　　Set Sub_Fld = Nothing
　　　　　　Set Myfso = Nothing
　　　　　　
　　　　　　For Each SchFld In Fld
　　　　　　'ファイル名を指定
　　　　　　Filename = Dir(SchFld & "\" & "*表.xls", VBnomal)
　　　　　　
　　　　　　Do While Filename <> ""
　　　　　　
　　　　　　'ファイルを開く
　　　　　　Workbooks.Open SchFld & "\" & Filename
　　　　　　
　　　　　　　'シートの有無を確認
　　　　　　　
　　　　　　　ShtName = "VER5.0"　　　　　　
　　　　　　　 Flg = True
　　　　　　
　　　　　　　For n = 1 To Worksheets.Count
　　　　　　　　　If StrConv(Worksheets(n).Name, vbUpperCase + vbNarrow) = ShtName Then
　　　　　　　　　　Flg = False
　　　　　　　　　　Exit For
　　　　　　　　 End If
　　　　　　　Next n
　　　　　　　
　　　　　　　　'シートVer5.0がある場合
　　　　　　　　If Flg = False Then
　　　　　　　　　 'MsgBox ShtName & "は存在します。"
　　　　　　　　　
　　　　　　　　　　 'シートを選択
　　　　　　　　　　With Sheets("Ver5.0")


　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　
　　　　　　　　　　End With
　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　Workbooks(Filename).Save
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　'シートVer5.0がない場合
　　　　　　　　Else
　　　　　　　　　　
　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　End If
　　　　　'End If
　　　　
　　　　　Filename = Dir()
　　　　Loop
　　 Next　　　
End Sub
【22620】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/24(木) 21:48 -
引用なし
パスワード
   ▼kazu さん：

ありがとうございます。
動作させてみましたが、”For Each SchFld In Fld”の部分で
『型が一致しません』というエラーがでてしまいます。。
ご教授いただけるようお願いいたします。。

>Sub test()
>
>　　Dim Mydir As String
>　　Dim Filename As String
>　　Dim mySh As String
>　　Dim a As String
>　　Dim myRng As Range
>　　Dim i As Long
>　　Dim n, ShtName, Flg
>　　Dim AryFld()
>　　
>　　　　　　Set Myfso = CreateObject("Scripting.FileSystemObject")
>　　　　　　Set Sub_Fld = Myfso.GetFolder("C:\test").SubFolders
>　　　　　　Redim Preserve AryFld(Sub_Fld.Count)
>　　　　　　n = 1　　　　
>　　　　　　ReDim AryFld(Sub_Fld.Count)
>　　　　　　AryFld(0) = "C:\test"
>　　　　　　n = 1　　　　
>　　　　　　For Each Fld In Sub_Fld
>　　　　　　 AryFld(N) = Fld.Path
>　　　　　　 n = n + 1
>　　　　　　Next
>　　　　　　Set Sub_Fld = Nothing
>　　　　　　Set Myfso = Nothing
>　　　　　　
>　　　　　　For Each SchFld In Fld
>　　　　　　'ファイル名を指定
>　　　　　　Filename = Dir(SchFld & "\" & "*表.xls", VBnomal)
>　　　　　　
>　　　　　　Do While Filename <> ""
>　　　　　　
>　　　　　　'ファイルを開く
>　　　　　　Workbooks.Open SchFld & "\" & Filename
>　　　　　　
>　　　　　　　'シートの有無を確認
>　　　　　　　
>　　　　　　　ShtName = "VER5.0"　　　　　　
>　　　　　　　 Flg = True
>　　　　　　
>　　　　　　　For n = 1 To Worksheets.Count
>　　　　　　　　　If StrConv(Worksheets(n).Name, vbUpperCase + vbNarrow) = ShtName Then
>　　　　　　　　　　Flg = False
>　　　　　　　　　　Exit For
>　　　　　　　　 End If
>　　　　　　　Next n
>　　　　　　　
>　　　　　　　　'シートVer5.0がある場合
>　　　　　　　　If Flg = False Then
>　　　　　　　　　 'MsgBox ShtName & "は存在します。"
>　　　　　　　　　
>　　　　　　　　　　 'シートを選択
>　　　　　　　　　　With Sheets("Ver5.0")
>
>
>　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
>　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
>　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
>　　　　　　　　　　　　　End If
>　　　　　　　　　　　　Next
>　　　　　　　　　　　　
>　　　　　　　　　　End With
>　　　　　　　　　　
>　　　　　　　　　　　　　　　　　　
>　　　　　　　　　　Workbooks(Filename).Save
>　　　　　　　　　　Workbooks(Filename).Close
>　　　　　　　　　　
>　　　　　　　　'シートVer5.0がない場合
>　　　　　　　　Else
>　　　　　　　　　　
>　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
>　　　　　　　　　　Workbooks(Filename).Close
>　　　　　　　　End If
>　　　　　'End If
>　　　　
>　　　　　Filename = Dir()
>　　　　Loop
>　　 Next　　　
>End Sub
【22622】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 22:06 -
引用なし
パスワード
   ▼桜 さん：

すみません、自分の仕事しながらなもので、タイプミスしてました。

以下の個所を変更下さい。

誤)For Each SchFld In Fld

正)For Each SchFld In AryFld
【22628】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/24(木) 22:48 -
引用なし
パスワード
   ▼kazu さん：

お忙しい中、ありがとうございました。
動作確認してみたのですが、
サブフォルダ配下の処理ができませんでした。
特にエラー等がでているわけではないのですが。。

恐縮ですが、、
お時間ある際にご教授いただけるようお願いいたします。
【22630】Re:Dir関数でサブフォルダまでファイル検...
発言  ichinose  - 05/2/24(木) 22:57 -
引用なし
パスワード
   ▼桜 さん、kazu さん、こんばんは。

>
>お忙しい中、ありがとうございました。
>動作確認してみたのですが、
>サブフォルダ配下の処理ができませんでした。
>特にエラー等がでているわけではないのですが。。
>
>恐縮ですが、、
>お時間ある際にご教授いただけるようお願いいたします。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=13218;id=excel

↑ここに似たような御質問がありました。
Filesearch、FSO、Dir関数でありますから、
参考にして下さい。
【22632】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 23:19 -
引用なし
パスワード
   桜 さん, ichinose　さんこんばんは。

vbNormalのスペルが違います。

これで動作しませんか？

誤)　Filename = Dir(SchFld & "\" & "*表.xls", VBnomal)

正)　Filename = Dir(SchFld & "\" & "*表.xls", vbNormal)
【22641】Re:Dir関数でサブフォルダまでファイル検...
お礼  MMX  - 05/2/25(金) 10:17 -
引用なし
パスワード
   ＞kazu さん：

おはようございます。

kazuさんの提示されたソースの
稼働が確認できましたのでご報告いたします。

横ヤリで恐縮ですが
参考になる部分がありましたので。。。
ありがとうございました。


桜さん〜、動きましたよー。
【22642】Re:Dir関数でサブフォルダまでファイル検...
発言  でれすけ  - 05/2/25(金) 10:31 -
引用なし
パスワード
   こんにちは。

もうほとんど解決のようなんですが、
Dir関数で書いてみましたので、何かの参考になれば。


Option Explicit

Sub sample()

Dim i As Long, n As Long
Dim FoundFiles As Variant
Dim WB As Workbook, WS As Worksheet

n = RecDir("d:\", "*表.xls", FoundFiles)

For i = 1 To n
　 Set WB = Workbooks.Open(FoundFiles(i), ReadOnly:=True)
　 If SheetExist(WB, "ver5.0", WS) Then
　　　MsgBox WB.Name & "に" & WS.Name & "がみつかりました"
　 ElseIf SheetExist(WB, "Ver5.0", WS) Then
　　　MsgBox WB.Name & "に" & WS.Name & "がみつかりました"
　 End If
　 With WS
　　　 'ワークシートに対する処理
　 End With
　 WB.Close SaveChanges:=False
Next

End Sub


Function SheetExist(WB As Workbook, ShName As Variant, Sh As Worksheet) As Boolean
On Error GoTo Not_Exist
　Set Sh = WB.Worksheets(ShName)
　SheetExist = True
　Exit Function
Not_Exist:
　SheetExist = False: Set Sh = Nothing
End Function

Function RecDir(ByVal Path As String, ByVal FileFilter As String, ByRef FoundFiles As Variant) As Long
Dim FileNames() As String, Folders() As String
Dim nFile As Long, nFolder As Long
Dim ret As Variant, i As Long, j As Long, n As Long

nFile = 0: nFolder = 0
Path = IIf(Right(Path, 1) = "\", Path, Path & "\")

ret = Dir(Path & FileFilter, vbNormal)
Do While ret <> ""
　If Path <> "." And Path <> ".." Then
　　 If (GetAttr(Path & ret) And vbNormal) = vbNormal Then
　　　　nFile = nFile + 1
　　　　ReDim Preserve FileNames(1 To nFile)
　　　　FileNames(nFile) = Path & ret
　　 End If
　End If
　ret = Dir
Loop

ret = Dir(Path, vbDirectory)
Do While ret <> ""
　If ret <> "." And ret <> ".." Then
　　 If (GetAttr(Path & ret) And vbDirectory) = vbDirectory Then
　　　　nFolder = nFolder + 1
　　　　ReDim Preserve Folders(1 To nFolder)
　　　　Folders(nFolder) = Path & ret
　　 End If
　End If
　ret = Dir
Loop

For i = 1 To nFolder
　n = RecDir(Folders(i), FileFilter, ret)
　If n > 0 Then
　　 ReDim Preserve FileNames(1 To nFile + n)
　　 For j = 1 To n
　　　　FileNames(nFile + j) = ret(j)
　　 Next
　　 nFile = nFile + n
　End If
Next

RecDir = nFile: FoundFiles = FileNames
Erase FileNames, Folders
End Function
【22646】Re:Dir関数でサブフォルダまでファイル検...
お礼  桜  - 05/2/25(金) 12:02 -
引用なし
パスワード
   ▼kazuさん,ichinoseさん、でれすけ さん：


ありがとうございます。
うまく動作することができました！

みなさんの親切なご教授のおかげで
大変助かりました。

本当にありがとうございます！
【22681】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/28(月) 1:12 -
引用なし
パスワード
   >▼kazuさん,ichinoseさん、でれすけ さん：

度々質問で恐縮ですが、、

下記コードで、Sub_Fld.Countとしてあるので
２階層以上検索できるようになっているのでしょうか？

動作させてみたところ、指定した１つ下のサブフォルダまでは検索できるのですが
２階層以上下のフォルダまでは検索できる方法はありますか？
フォルダ配下にサブフォルダが不特定数ある場合に下記を応用することは
可能でしょうか？　

度重なる質問で恐縮ですがよろしくお願いいたします。

Sub test()

　　Dim Mydir As String
　　Dim Filename As String
　　Dim mySh As String
　　Dim a As String
　　Dim myRng As Range
　　Dim i As Long
　　Dim n, ShtName, Flg
　　Dim AryFld()
　　
　　　　　　Set Myfso = CreateObject("Scripting.FileSystemObject")
　　　　　　Set Sub_Fld = Myfso.GetFolder("C:\test").SubFolders
　　　　　　Redim Preserve AryFld(Sub_Fld.Count)
　　　　　　n = 1　　　　
　　　　　　ReDim AryFld(Sub_Fld.Count)
　　　　　　AryFld(0) = "C:\test"
　　　　　　n = 1　　　　
　　　　　　For Each Fld In Sub_Fld
　　　　　　 AryFld(N) = Fld.Path
　　　　　　 n = n + 1
　　　　　　Next
　　　　　　Set Sub_Fld = Nothing
　　　　　　Set Myfso = Nothing
　　　　　　
　　　　　　For Each SchFld In AryFld
　　　　　　'ファイル名を指定
　　　　　　Filename = Dir(SchFld & "\" & "*表.xls", vbNormal)
　　　　　　
　　　　　　Do While Filename <> ""
　　　　　　
　　　　　　'ファイルを開く
　　　　　　Workbooks.Open SchFld & "\" & Filename
　　　　　　
　　　　　　　'シートの有無を確認
　　　　　　　
　　　　　　　ShtName = "VER5.0"　　　　　　
　　　　　　　 Flg = True
　　　　　　
　　　　　　　For n = 1 To Worksheets.Count
　　　　　　　　　If StrConv(Worksheets(n).Name, vbUpperCase + vbNarrow) = ShtName Then
　　　　　　　　　　Flg = False
　　　　　　　　　　Exit For
　　　　　　　　 End If
　　　　　　　Next n
　　　　　　　
　　　　　　　　'シートVer5.0がある場合
　　　　　　　　If Flg = False Then
　　　　　　　　　 'MsgBox ShtName & "は存在します。"
　　　　　　　　　
　　　　　　　　　　 'シートを選択
　　　　　　　　　　With Sheets("Ver5.0")


　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　
　　　　　　　　　　End With
　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　Workbooks(Filename).Save
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　'シートVer5.0がない場合
　　　　　　　　Else
　　　　　　　　　　
　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　End If
　　　　　'End If
　　　　
　　　　　Filename = Dir()
　　　　Loop
　　 Next　　　
End Sub
【22682】Re:Dir関数でサブフォルダまでファイル検...
発言  ちゃっぴ  - 05/2/28(月) 1:21 -
引用なし
パスワード
   File検索はFAQなので、こちらにまとめときました。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=74;id=FAQ

参考にしてください。
(近々、WMI Versionものっけようかな？)

ちなみにDir関数にはPath名がANSI換算で256Byteまでという制限があり、
(これは、Dir関数に限らず[VBA.FileSystem]Class全般にいえます)
また、第二引数Attributesを意識して使わないと、
問題になるCaseが多々あります。

なので、私は使用しません。
【22683】Re:Dir関数でサブフォルダまでファイル検...
回答  でれすけ  - 05/2/28(月) 1:28 -
引用なし
パスワード
   こんばんは

>下記コードで、Sub_Fld.Countとしてあるので
>２階層以上検索できるようになっているのでしょうか？
現状ではなってないようですね。

>２階層以上下のフォルダまでは検索できる方法はありますか？
フォルダ名を取得したらその下のフォルダもずっと掘り下げて行くように
書き直す必要があります。

私が提示したサンプルのRecDirは、再起的に自分自身を呼びだして
下のフォルダに降りていくように作ってあります。参考にしてください。

ちなみに、私のSub Sampleには明らかにまずいところがあるので、
適当に修正して動かしてください。

おやすみなさい。
【22689】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/28(月) 13:27 -
引用なし
パスワード
   　StopLv 　←　何階層堀り下げるかの設定。
StopLv =　999　なら最下位層迄です。

会社なんで、Officeが97環境しか無いんで
Split97 という関数使ってますが、2000以降であればSplitで問題ないと思います。


Sub test()

　　Dim Mydir As String
　　Dim Filename As String
　　Dim mySh As String
　　Dim a As String
　　Dim myRng As Range
　　Dim i As Long
　　Dim n, ShtName, Flg
　　Dim AryFld()
　　
Cons_Fld = "C:\test"
StopLv = 999
Set myFso = CreateObject("Scripting.FileSystemObject")

Set myFld = myFso.GetFolder(Cons_Fld).SubFolders
ReDim AryFld(0)
AryFld(0) = Cons_Fld
n = 1
c = 1
　
Do
　　'アクセス出来ないフォルダ（System Volume Information等）へのアクセス考慮
　　On Error Resume Next
　　If Not Err Then
　　　　For Each Fld In myFld
　　　　　　If Not IsEmpty(Fld) Then
　　　　　　　　If Lv_Chk(Cons_Fld, Fld.Path) <= StopLv - 1 Or StopLv = 999 Then
　　　　　　　　　　ReDim Preserve AryFld(n)
　　　　　　　　　　AryFld(n) = Fld.Path
　　　　　　　　　　n = n + 1
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Else
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　If i > c Then Set myFld = myFso.GetFolder(AryFld(c)).SubFolders
　　c = c + 1
Loop Until c > i

Set Sub_Fld = Nothing
Set Myfso = Nothing
　　　　　　
　　　　　　For Each SchFld In AryFld
　　　　　　'ファイル名を指定
　　　　　　Filename = Dir(SchFld & "\" & "*表.xls", vbNormal)
　　　　　　
　　　　　　Do While Filename <> ""
　　　　　　
　　　　　　'ファイルを開く
　　　　　　Workbooks.Open SchFld & "\" & Filename
　　　　　　
　　　　　　　'シートの有無を確認
　　　　　　　
　　　　　　　ShtName = "VER5.0"　　　　　　
　　　　　　　 Flg = True
　　　　　　
　　　　　　　For n = 1 To Worksheets.Count
　　　　　　　　　If StrConv(Worksheets(n).Name, vbUpperCase + vbNarrow) = ShtName Then
　　　　　　　　　　Flg = False
　　　　　　　　　　Exit For
　　　　　　　　 End If
　　　　　　　Next n
　　　　　　　
　　　　　　　　'シートVer5.0がある場合
　　　　　　　　If Flg = False Then
　　　　　　　　　 'MsgBox ShtName & "は存在します。"
　　　　　　　　　
　　　　　　　　　　 'シートを選択
　　　　　　　　　　With Sheets("Ver5.0")


　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　
　　　　　　　　　　End With
　　　　　　　　　　
　　　　　　　　　　　　　　　　　　
　　　　　　　　　　Workbooks(Filename).Save
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　　　
　　　　　　　　'シートVer5.0がない場合
　　　　　　　　Else
　　　　　　　　　　
　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
　　　　　　　　　　Workbooks(Filename).Close
　　　　　　　　End If
　　　　　'End If
　　　　
　　　　　Filename = Dir()
　　　　Loop
　　 Next　　　
End Sub


Function Lv_Chk(Fld_Main, StrFld)
　　Cnt = InStr(1, Fld_Main, StrFld)
　　Tmp = Split97(Mid(StrFld, Len(Fld_Main) + 1), "\")
　　Lv_Chk = UBound(Tmp)
End Function

Function Split97(ByVal StrTmp, ByVal Strbunri)
　　Dim Split97Tmp()　　'配列一時格納用
　　Dim i As Long　　　 'カウンタ変数
　　Dim IntTmp As Long　'区切り文字位置格納用変数
　　
　　IntTmp = InStr(1, StrTmp, Strbunri)
　　If IntTmp = 0 Then
　　　　ReDim Split97Tmp(0)
　　　　Split97Tmp(0) = StrTmp
　　Else
　　　　Do Until IntTmp = 0
　　　　　　ReDim Preserve Split97Tmp(i)
　　　　　　Split97Tmp(i) = Left(StrTmp, IntTmp - 1)
　　　　　　i = i + 1
　　　　　　StrTmp = Mid(StrTmp, IntTmp + Len(Strbunri))
　　　　　　IntTmp = InStr(1, StrTmp, Strbunri)
　　　　Loop
　　End If
　　ReDim Preserve Split97Tmp(i)
　　Split97Tmp(i) = StrTmp
　　Split97 = Split97Tmp
End Function
【22691】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/28(月) 15:11 -
引用なし
パスワード
   ▼kazu さん：


ありがとうございます。

動作確認してみました。。
階層を９９９（最下位までと指定している）のですがやはり、１階層下までしか
検索してないようなのですが、２０００と９７で動作が違うのでしょうか？

また、質問ばかりになってしまうのですが、
'アクセス出来ないフォルダ（System Volume Information等）へのアクセス考慮
というのは具体的に何を行っているのでしょうか？

お忙しい中恐縮ですが、ご教授お願いいたします。


>　StopLv 　←　何階層堀り下げるかの設定。
>StopLv =　999　なら最下位層迄です。
>
>会社なんで、Officeが97環境しか無いんで
>Split97 という関数使ってますが、2000以降であればSplitで問題ないと思います。
>
>
>Sub test()
>
>　　Dim Mydir As String
>　　Dim Filename As String
>　　Dim mySh As String
>　　Dim a As String
>　　Dim myRng As Range
>　　Dim i As Long
>　　Dim n, ShtName, Flg
>　　Dim AryFld()
>　　
>Cons_Fld = "C:\test"
>StopLv = 999
>Set myFso = CreateObject("Scripting.FileSystemObject")
>
>Set myFld = myFso.GetFolder(Cons_Fld).SubFolders
>ReDim AryFld(0)
>AryFld(0) = Cons_Fld
>n = 1
>c = 1
>　
>Do
>　　'アクセス出来ないフォルダ（System Volume Information等）へのアクセス考慮
>　　On Error Resume Next
>　　If Not Err Then
>　　　　For Each Fld In myFld
>　　　　　　If Not IsEmpty(Fld) Then
>　　　　　　　　If Lv_Chk(Cons_Fld, Fld.Path) <= StopLv - 1 Or StopLv = 999 Then
>　　　　　　　　　　ReDim Preserve AryFld(n)
>　　　　　　　　　　AryFld(n) = Fld.Path
>　　　　　　　　　　n = n + 1
>　　　　　　　　End If
>　　　　　　End If
>　　　　Next
>　　Else
>　　　　Err.Clear
>　　End If
>　　On Error GoTo 0
>　　If i > c Then Set myFld = myFso.GetFolder(AryFld(c)).SubFolders
>　　c = c + 1
>Loop Until c > i
>
>Set Sub_Fld = Nothing
>Set Myfso = Nothing
>　　　　　　
>　　　　　　For Each SchFld In AryFld
>　　　　　　'ファイル名を指定
>　　　　　　Filename = Dir(SchFld & "\" & "*表.xls", vbNormal)
>　　　　　　
>　　　　　　Do While Filename <> ""
>　　　　　　
>　　　　　　'ファイルを開く
>　　　　　　Workbooks.Open SchFld & "\" & Filename
>　　　　　　
>　　　　　　　'シートの有無を確認
>　　　　　　　
>　　　　　　　ShtName = "VER5.0"　　　　　　
>　　　　　　　 Flg = True
>　　　　　　
>　　　　　　　For n = 1 To Worksheets.Count
>　　　　　　　　　If StrConv(Worksheets(n).Name, vbUpperCase + vbNarrow) = ShtName Then
>　　　　　　　　　　Flg = False
>　　　　　　　　　　Exit For
>　　　　　　　　 End If
>　　　　　　　Next n
>　　　　　　　
>　　　　　　　　'シートVer5.0がある場合
>　　　　　　　　If Flg = False Then
>　　　　　　　　　 'MsgBox ShtName & "は存在します。"
>　　　　　　　　　
>　　　　　　　　　　 'シートを選択
>　　　　　　　　　　With Sheets("Ver5.0")
>
>
>　　　　　　　　　　　　For i = 5 To .Range("j65536").End(xlUp).Row
>　　　　　　　　　　　　　If .Cells(i, "j").Value <> "" Then
>　　　　　　　　　　　　　　 .Cells(i, "j").Offset(, 1).Value = "OK"
>　　　　　　　　　　　　　End If
>　　　　　　　　　　　　Next
>　　　　　　　　　　　　
>　　　　　　　　　　End With
>　　　　　　　　　　
>　　　　　　　　　　　　　　　　　　
>　　　　　　　　　　Workbooks(Filename).Save
>　　　　　　　　　　Workbooks(Filename).Close
>　　　　　　　　　　
>　　　　　　　　'シートVer5.0がない場合
>　　　　　　　　Else
>　　　　　　　　　　
>　　　　　　　　　 ' MsgBox ShtName & "は存在しません。"
>　　　　　　　　　　Workbooks(Filename).Close
>　　　　　　　　End If
>　　　　　'End If
>　　　　
>　　　　　Filename = Dir()
>　　　　Loop
>　　 Next　　　
>End Sub
>
>
>Function Lv_Chk(Fld_Main, StrFld)
>　　Cnt = InStr(1, Fld_Main, StrFld)
>　　Tmp = Split97(Mid(StrFld, Len(Fld_Main) + 1), "\")
>　　Lv_Chk = UBound(Tmp)
>End Function
>
>Function Split97(ByVal StrTmp, ByVal Strbunri)
>　　Dim Split97Tmp()　　'配列一時格納用
>　　Dim i As Long　　　 'カウンタ変数
>　　Dim IntTmp As Long　'区切り文字位置格納用変数
>　　
>　　IntTmp = InStr(1, StrTmp, Strbunri)
>　　If IntTmp = 0 Then
>　　　　ReDim Split97Tmp(0)
>　　　　Split97Tmp(0) = StrTmp
>　　Else
>　　　　Do Until IntTmp = 0
>　　　　　　ReDim Preserve Split97Tmp(i)
>　　　　　　Split97Tmp(i) = Left(StrTmp, IntTmp - 1)
>　　　　　　i = i + 1
>　　　　　　StrTmp = Mid(StrTmp, IntTmp + Len(Strbunri))
>　　　　　　IntTmp = InStr(1, StrTmp, Strbunri)
>　　　　Loop
>　　End If
>　　ReDim Preserve Split97Tmp(i)
>　　Split97Tmp(i) = StrTmp
>　　Split97 = Split97Tmp
>End Function
>
【22693】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/28(月) 18:09 -
引用なし
パスワード
   変更お願いします。

我ながら・・・タイプミス多いですね・・・（＾＾；
すみません。

誤)　If i > c Then Set myFld = myFso.GetFolder(AryFld(c)).SubFolders

正)　If n > c Then Set myFld = myFso.GetFolder(AryFld(c)).SubFolders

誤)　Loop Until c > i

正)　Loop Until c > n
【22694】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/28(月) 18:13 -
引用なし
パスワード
   ↓、回答してませんでしたね。

また、質問ばかりになってしまうのですが、
'アクセス出来ないフォルダ（System Volume Information等）へのアクセス考慮
というのは具体的に何を行っているのでしょうか？


ｼｽﾃﾑ的にアクセスが許可されていないﾌｫﾙﾀﾞのサブﾌｫﾙﾀﾞを検索すると、
エラーが返りますので、その際はそのﾌｫﾙﾀﾞは無かった事にして
（エラーを無視して）次のﾌｫﾙﾀﾞを検索する。

ただそれだけの事です。
【22700】Re:Dir関数でサブフォルダまでファイル検...
質問  桜  - 05/2/28(月) 20:13 -
引用なし
パスワード
   ▼kazu さん：

ありがとうございます！
最下位階層までのファイルを処理することができました！

ご親切に本当にありがとうございます。

またまた恐縮なのですが、
数点、ご教授お願いします。

1.↓この部分は　Lvをチェックしてどのくらいの階層まで
　処理をするかをカウントしているのでしょうか？？

Function Lv_Chk(Fld_Main, StrFld)
　　　　　　Cnt = InStr(1, Fld_Main, StrFld)
　　　　　　Tmp = Split(Mid(StrFld, Len(Fld_Main) + 1), "\")
　　　　　　Lv_Chk = UBound(Tmp)
　　　　End Function


2.Split関数をヘルプで調べてみたところ、分割状態を設定するとあったのですが
　具体的には今回の場合どのような処理を行っているのでしょうか？？


お忙しい中大変恐縮ですが、ご教授お願いいたします。。
【22704】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/28(月) 21:43 -
引用なし
パスワード
   ▼桜 さん：
Function Lv_Chk(Fld_Main, StrFld)
　　　　　　Cnt = InStr(1, Fld_Main, StrFld)
　　　　　　Tmp = Split(Mid(StrFld, Len(Fld_Main) + 1), "\")
　　　　　　Lv_Chk = UBound(Tmp)
　　　　End Function


Cnt = InStr(1, Fld_Main, StrFld) ←　無いなら無いでもいいですね・・・。

Tmp = Split(Mid(StrFld, Len(Fld_Main) + 1), "\")

例えば　StrFld=C:\TEST\A\B\CC　というﾌｫﾙﾀﾞだったとします。
Fld_Main　=　C:\TEST　ですね。

ここでTmpの値は

Tmp(0) = ""　　
Tmp(1) = "A"　
Tmp(2) = "B"
Tmp(3) = "CC"

となります。
つまり、文字列　"\"にて区切って配列化している訳です。

Lv_Chk = UBound(Tmp)
つまり　Lv_Chkは3となります。

\文字列で切るって事は、階層数をカウントしてるのとおんなじ事になります。

ん？？でも何で　-1したんだろ？？・・・。
何か矛盾してる気も・・・。

-1　要らないかも・・・。

何か頭まわんないです。
やっぱ私のPrg適当ですね（＾＾；　反省します。はぃ。

こんな感じで解ってもらえますか？
【22705】Re:Dir関数でサブフォルダまでファイル検...
お礼  イオン  - 05/2/28(月) 21:48 -
引用なし
パスワード
   ▼kazu さん：

ありがとうございます！
ご親切に説明していただき勉強になりました。

お忙しい中ほんとうにありがとうございました。
【22722】Re:Dir関数でサブフォルダまでファイル検...
お礼  桜  - 05/3/1(火) 10:18 -
引用なし
パスワード
   ▼kazu さん：

kazuさん、その他の皆様、
いろいろとご教授していただきありがとうございました。

また何かありましたらよろしくお願いいたします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10283 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free