Excel VBA質問箱 IV

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

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


11926 / 13645 ツリー ←次へ | 前へ→

【13218】検索マクロ まみ 04/4/28(水) 9:46 質問[未読]
【13231】Re:検索マクロ Jaka 04/4/28(水) 14:56 回答[未読]
【13255】Re:検索マクロ ichinose 04/4/28(水) 23:57 回答[未読]
【13262】Re:検索マクロ Hirofumi 04/4/29(木) 14:15 回答[未読]

【13218】検索マクロ
質問  まみ  - 04/4/28(水) 9:46 -

引用なし
パスワード
   はじめまして


Sub test_1()
Dim myFile As String, File_Path As String, File_Name As String, Fld_Path As String
Dim myList As Variant
Dim myCount As Integer, myChk As Boolean
Dim i As Integer
Const myDir As String = "D:\mm\oo\tt\ee\" '検索ディレクトリ
myFile = CStr(Cells(1, 1)) & "*" 'ファイル名(セルの値)
'指定階層検索
myChk = False
File_Name = myDir & myFile
File_Path = Dir(File_Name, vbNormal)
Do While File_Path <> ""
If File_Path Like myFile Then
Workbooks.Open Filename:=myDir & File_Path
myChk = True
Exit Do
End If
File_Path = Dir()
Loop
If myChk = True Then
Exit Sub
End If
'指定階層内フォルダ検索
myCount = 0
ReDim myList(myCount)
File_Path = Dir(myDir, vbDirectory)
Do While File_Path <> ""
myList(myCount) = myDir & File_Path
myCount = myCount + 1
ReDim Preserve myList(myCount)
File_Path = Dir()
Loop

For i = 0 To myCount - 1
On Error Resume Next       
File_Name = myList(i) & "\" & myFile
File_Path = Dir(File_Name, vbNormal)
Do While File_Path <> ""
If File_Path Like myFile Then
Workbooks.Open Filename:=myList(i) & "\" & File_Path
myChk = True
Exit Do
End If
File_Path = Dir()
Loop
If myChk = True Then
Exit For
End If
Next i
If myChk = False Then
MsgBox "ファイルが見つかりません。"
End If

End Sub


というセルに入力したファイル名で始まるファイルを開くマクロですが、
今の状態では2階層しか検索できません。
3階層のものをつくりたいのですが、どのように追加したらよいでしょうか??

【13231】Re:検索マクロ
回答  Jaka  - 04/4/28(水) 14:56 -

引用なし
パスワード
   たぶんダメだと思いますけど...。

Sub FileSearcha()
 Dim dsk As String, 検索フィルダ名 As String, 検索ファイル名 As Variant

 検索フィルダ名 = "D:\mm\oo\tt\ee"
 検索ファイル名 = CStr(Cells(1, 1))
 '注)拡張子を除いたXXを含むファイル名が対象になっているみたいです。
 'ですので、※1の所でいちいち比較するという事になります。
 '検索ファイル名 = あああ だと
 'bbbあああ.txt、あああ4566.xls とかも拾っちゃいます。
 'また、FileSearchは、結構いいかげん見たいです。

 With Application.FileSearch
  .NewSearch
  .LookIn = 検索フィルダ名
  .SearchSubFolders = True
  .FileName = 検索ファイル名
  .MatchTextExactly = True
  .FileType = msoFileTypeAllFiles
  If .Execute() > 0 Then
    MsgBox .FoundFiles.Count & _
     " 個のファイルが見つかりました。"
    For i = 1 To .FoundFiles.Count
      MsgBox Dir(.FoundFiles(i))
      '※1
    Next i
  Else
    MsgBox "検索条件を満たすファイルはありません。"
  End If
 End With
End Sub

【13255】Re:検索マクロ
回答  ichinose  - 04/4/28(水) 23:57 -

引用なし
パスワード
   まみ さん、Jakaさん、こんばんは。

こんな風にしてみました。
3階層を捜索する例です。
まず、標準モジュール(Module1)に
'===================================================================
Sub main()
  Dim ans As Long
  Dim flnm As String
  ans = fold_open("D:\EXCELファイル", "Habm*.*", 3)
' "D:\EXCELファイル"というフォルダ以下を "Habm*.*"の条件で 3階層捜索します
' 尚、3の代わりにFalseにするとそれ以下の階層も捜索します
  If ans = 0 Then '見つかった
   flnm = fold_get() '見つかったパスを取得
   Do While flnm <> ""
'ここで本来は、オープン処理
     MsgBox flnm
     flnm = fold_get
     Loop
  Else
   If ans = 1 Then
     MsgBox "見つからない"
   Else
     MsgBox Error(ans)
     End If
   End If
  Call fold_close '内部データクリア
End Sub


標準モジュール(Module2)に
'===================================================================
Private f_cnt As Long
Private f_path() As String
Private f_idx As Long
'====================================================================
Function fold_open(ByVal stDir As String, ByVal f_file As String, ByVal 捜索階層) As Long
'指定されたパスを捜索開始パスとして、指定されたファイルを捜索します
'尚、ファイル名の大文字・小文字は区別しません
'input  : stDir-----捜索開始パス
'     f_file----捜索ファイル名
'     捜索階層---False-----開始パスから全ての階層を捜索する
'          数値(>0)-開始パスから指定された階層のフォルダを捜索する(1の場合は、開始パスのみ)
'output : fold_open 0--------条件に合ったファイルが1つ以上見つかった
'           1--------条件に合ったファイルは見つからない
'           その他---以上終了(エラーコード)
  On Error Resume Next
  Dim fso As Object
  Dim f_fld As Object
  fold_open = 0
  Erase f_path()
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set f_fld = fso.GetFolder(stDir)
  If Err.Number <> 0 Then
   fold_open = Err.Number
  Else
   f_cnt = 0
   Call fold_search(f_fld, f_file, 捜索階層)
   If f_cnt <= 0 Then
     fold_open = 1
   Else
     f_idx = 1
     End If
   End If
  Set fso = Nothing
  Set f_fld = Nothing
End Function
'========================================================================
Sub fold_search(ByVal f_fld As Object, ByVal f_file As String, ByVal 捜索階層)
  Dim sfld As Object
  Dim fl As Object
  Dim ret As Boolean
  For Each fl In f_fld.Files
   If UCase(fl.Name) Like UCase(f_file) Then
     ReDim Preserve f_path(1 To f_cnt + 1)
     f_path(f_cnt + 1) = fl.Path
     f_cnt = f_cnt + 1
     End If
   Next fl
  If VarType(捜索階層) = vbBoolean Then
   ret = True
  Else
   If 捜索階層 - 1 > 0 Then
     捜索階層 = 捜索階層 - 1
     ret = True
   Else
     ret = flase
     End If
   End If
  If ret = True Then
   For Each sfld In f_fld.SubFolders
     Call fold_search(sfld, f_file, 捜索階層)
     Next
   End If
End Sub
'======================================================================
Function fold_get() As String
'fold_openが0だった場合、順次見つかったファイルのフルパスを取り出す
'output: fold_get-----条件に合ったファイルのフルパス。空白の場合は、データの終わり
  If f_idx > UBound(f_path()) Then
   fold_get = ""
  Else
   fold_get = f_path(f_idx)
   f_idx = f_idx + 1
   End If
End Function
'========================================================================
Sub fold_close()
'ファイル捜索のクローズ処理
  Erase f_path
  f_idx = 0
  f_cnt = 0
End Sub

確認してみて下さい

【13262】Re:検索マクロ
回答  Hirofumi E-MAIL  - 04/4/29(木) 14:15 -

引用なし
パスワード
   こんな形で善いと思うけど?
階層の勘定の仕方が人によって違うので
このコードの場合は、
探し始めるフォルダを0、その下のフォルダを1、またその下を2と
勘定しています

Option Explicit

Sub test_2()

  Dim i As Long
  Dim strFolderPath As String
  Dim strSearchFile As String
  Dim vntFileNames As Variant
  
'  strFolderPath = "D:\mm\oo\tt\ee\" '検索ディレクトリ
  strFolderPath = ThisWorkbook.Path
'  strSearchFile = CStr(Cells(1, 1)) & "*" 'ファイル名(セルの値)
  strSearchFile = CStr(Cells(1, 1)) & "*.xls" 'ファイル名(セルの値)

  vntFileNames = FilesList(strFolderPath, strSearchFile, 3)
    
  If vntFileNames(0) <> "" Then
    For i = 0 To UBound(vntFileNames)
      Workbooks.Open FileName:=vntFileNames(i)
    Next i
  Else
    MsgBox "ファイルが見つかりません。"
  End If

End Sub

Public Function FilesList(ByVal strFolderPath As String, _
            ByVal strSearchFile As String, _
            Optional lngSubDir As Long = -1) As Variant

  'lngSubDirの値:探し始めのフォルダ=0、その下=1・・
  
  Dim i As Long
  Dim j As Long
  Dim strFolders() As String
  Dim strFileName As String
  Dim strFileNames() As String
  
  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If
    
  'フォルダのListを作成
  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    ListingFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If
  
  j = 0
  ReDim strFileNames(j)
  For i = 0 To UBound(strFolders)
    'ディレクトリ内の全ての標準ファイルを列挙
    strFileName = Dir(strFolders(i) & strSearchFile)
    Do Until strFileName = ""
      ReDim Preserve strFileNames(j)
      strFileNames(j) = strFolders(i) & strFileName
      j = j + 1
      strFileName = Dir
    Loop
  Next i
    
  FilesList = strFileNames()
  
End Function

Private Sub ListingFolders(ByVal strFilesPath As String, _
              strDirList() As String, _
              lngNextData As Long, _
              lngSubDir As Long)

  Dim i As Long
  Dim j As Long
  Dim lngNow As Long
  Dim strFileName As String

  '結果用配列の書き込み位置を取得
  i = lngNextData
  
  'サブディレクトリの結果リストと、一時的なリストを作成
  strFileName = Dir(strFilesPath, vbDirectory)
  Do Until strFileName = ""
    '現在のディレクトリと親ディレクトリを無視
    If strFileName <> "." And strFileName <> ".." Then
      'ディレクトリ以外を無視
      If GetAttr(strFilesPath & strFileName) _
                    And vbDirectory Then
        ReDim Preserve strDirList(i)
        '結果リストに追加
        strDirList(i) = strFilesPath & strFileName & "\"
        i = i + 1
      End If
    End If
    strFileName = Dir
  Loop
  
  j = lngNextData
  lngNextData = i
  'ディレクトリの階層を一つ下げる
  lngSubDir = lngSubDir - 1
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '各ディレクトリを再帰的に処理
    For i = j To lngNextData - 1
      lngNow = lngSubDir
      ListingFolders strDirList(i), strDirList(), _
                      lngNextData, lngNow
    Next i
  End If

End Sub

11926 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free