Excel VBA質問箱 IV

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

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


68025 / 76734 ←次へ | 前へ→

【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

確認してみて下さい

2 hits

【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 回答

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