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)存在すれば0、存在しなければ1を返す。
'---
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とDir関数を組み合わせて
使用することは可能なのでしょうか?

【22613】Re:Dir関数でサブフォルダまでファイル検...
発言  kazu  - 05/2/24(木) 19:46 -

引用なし
パスワード
   桜 さん

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

下記はサブフォルダが複数ある場合にも使用可能でしょうか?
↑ も可能です。配列として格納されます。

【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としてあるので
2階層以上検索できるようになっているのでしょうか?

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

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

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としてあるので
>2階層以上検索できるようになっているのでしょうか?
現状ではなってないようですね。

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

私が提示したサンプルの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 さん:


ありがとうございます。

動作確認してみました。。
階層を999(最下位までと指定している)のですがやはり、1階層下までしか
検索してないようなのですが、2000と97で動作が違うのでしょうか?

また、質問ばかりになってしまうのですが、
'アクセス出来ないフォルダ(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