Excel VBA 質問スレ Part83 (611ﾚｽ)
上下前次1-新
抽出解除 ﾚｽ栞
ﾘﾛｰﾄﾞ規制です｡10分ほどで解除するので､他のﾌﾞﾗｳｻﾞへ避難してください｡
417(3): デフォルトの名無しさん [sage] 2025/07/17(木) 08:47:01.58 ID:sGHKyXGW(1) AAS
>>410Dirでワイルドカードが使えるので、こんな感じに仕上げてみた
※ヒットするパスの例 → C:\Documents\A001\B000X1\Excel\20250717\FileABC001.xlsx
HomePath = "C:\Documents"
SearchPath = "A???\B*\Excel\2025????\File*.xlsx"
ResultPath = HomePath
SearchPathList = Split(SearchPath, "\")
For I = 0 To UBound(SearchPathList)
If Dir(ResultPath) <> "" Then
ResultPath = "ファイルの下は何もないよ！"
Exit For
End If
FolderName = Dir(ResultPath & "\" & SearchPathList(I), vbDirectory)
If FolderName = "" Then
ResultPath = "そんなパスはないよ！"
Exit For
End If
ResultPath = ResultPath & "\" & FolderName
Next
MsgBox "これかな？" & vbCrLf & ResultPath
419: デフォルトの名無しさん [] 2025/07/17(木) 20:37:37.93 ID:zBpNwhAR(2/4) AAS
>>417
正規表現の様な事ができたのでしょうか？
421: デフォルトの名無しさん [] 2025/07/17(木) 21:05:30.67 ID:zBpNwhAR(4/4) AAS
>>417
本当に複数の階層で部分一致できますでしょうか？
426: デフォルトの名無しさん [sage] 2025/07/18(金) 08:22:30.72 ID:avd6O0J8(1) AAS
>>417 はちょっと手抜きしてたので、ちゃんと作り直した｡
Sub 使い方()
Set Result = New Collection
DirMulti "C:\Documents", "A???\B*\Excel\2025????\File*.xlsx", Result, vbNormal
(以下略)
End Sub
Sub DirMulti(HomePath, SearchPath, ResultCollection, Optional Attributes As VbFileAttribute = vbNormal)
Pos = InStr(SearchPath & "\", "\")
Search = Left(SearchPath, Pos - 1)
NextSearch = Mid(SearchPath, Pos + 1)
Set SearchResult = New Collection
Res = Dir(HomePath & "\" & Search, vbDirectory Or Attributes)
Do While Res <> ""
If Res <> "." And Res <> ".." Then SearchResult.Add Res
Res = Dir()
Loop
If NextSearch = "" Then
For Each Res In SearchResult
ResultCollection.Add HomePath & "\" & Res
Next
Else
For Each Res In SearchResult
If (GetAttr(HomePath & "\" & Res) And vbDirectory) <> 0 Then
DirMulti HomePath & "\" & Res, NextSearch, ResultCollection, Attributes
End If
Next
End If
End Sub
上下前次1-新書関写板覧索設栞歴
ｽﾚ情報 赤ﾚｽ抽出 画像ﾚｽ抽出 歴の未読ｽﾚ AAｻﾑﾈｲﾙ
ぬこの手 ぬこTOP 0.029s