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

- 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 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free