[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAのファイル検索で、Text関数の書式記号を使用したい』（みっきー）
Excel VBAで、日付文字列の含まれたファイル名について、
ExcelのText関数の書式記号をワイルドカード的に使って、
ファイル検索を行う方法はありませんでしょうか。
Excel VBAに詳しい方のご回答がいただけると嬉しいです。
お手数をお掛けしますが、どうぞよろしくお願いいたします。
(例) 検索文字列:SampleYYYYMMDD.xlsx→Sample20200715.xlsxがヒット 検索文字列:Sample_MMMDD.xlsx→Sample_Jul15.xlsxがヒット 検索文字列:SampleYY年M月D日.xlsx→Sample20年7月15日.xlsxがヒット
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
コードまで書いていただく必要はございませんが、できましたらExcel VBAに詳しい方に、
その判定ロジックの概要をご教示いただけると嬉しいです。
Excel VBA固有の機能を使うことで非常にスマートに書けることは往々にしてありますので。
（みっきー） 2020/07/15(水) 19:01
>日付文字列の含まれたファイル名 Format関数で日付を表示を変えてやるだけ？
例
dir("パス名\*" & format(date,"yyyymmdd") & "*.xlsx")
^^^^^^^^ ^^^^^^^^
（seiya） 2020/07/15(水) 19:17
例えば想定される範囲内の日付でループさせて、
seiyaさんの方法で検索をかけるロジックもあるかとは思います。
実用的な速度が得られるかは分かりませんが。。。
（みっきー） 2020/07/16(木) 09:26
Public Function fCheck(cOrg As String, cFmt As String) As Boolean
Dim cFmt2 As String
Dim cw As String
Dim cw2 As String
Dim iw As Long
Dim iw2 As Long
fCheck = False
cw = cOrg
cFmt2 = cFmt
iw = InStr(cFmt2, "MMM")
If 0 < iw Then
cw = Replace(cw, "Jan", "MMM")
'…
cw = Replace(cw, "Dec", "MMM")
If Mid(cw, iw, 3) <> "MMM" Then
Exit Function
End If
Mid(cw, iw, 3) = "MMM"
Mid(cFmt2, iw, 3) = "|||"
End If
iw = InStr(cFmt2, "YYYY")
If 0 < iw Then
cw2 = Mid(cw, iw, 4)
If IsNumeric(cw2) = False Then
Exit Function
End If
iw2 = Val(cw2)
If iw2 < 1900 Or 2999 < iw2 Then
Exit Function
End If
Mid(cw, iw, 4) = "YYYY"
Mid(cFmt2, iw, 4) = "||||"
End If
iw = InStr(cFmt2, "YY")
If 0 < iw Then
'…
End If
iw = InStr(cFmt2, "MM")
If 0 < iw Then
'…
End If
iw = InStr(cFmt, "DD")
If 0 < iw Then
'…
End If
iw = InStr(cFmt, "Y")
If 0 < iw Then
'…
End If
iw = InStr(cFmt, "M")
If 0 < iw Then
'…
End If
iw = InStr(cFmt, "D")
If 0 < iw Then
'…
End If
If cw = cFmt Then
fCheck = True
End If
End Function
フォーマットは必ず大文字指定する前提で、英語表記の月はPascal表記前提です。 大文字小文字の違いを吸収したい場合は、StrConvで大文字小文字をどちらかに統一してから比較すれば良いでしょう。
（???） 2020/07/16(木) 10:09
Dim f_d As String, f_m As String, da As String, d As Date, fso As Object, f As Variant
MsgBox "同一フォルダ内を検索します。"
f_d = InputBox("検索期間開始日を入力(YYYYMMDD)")
da = Left(f_d, 4) & "/" & Mid(f_d, 5, 2) & "/" & Right(f_d, 2)
If Not IsDate(da) Then MsgBox "日付不正", vbCritical: Exit Sub
f_m = InputBox("表示形式を入力(例:YYYY年M月D日)")
Set fso = CreateObject("Scripting.filesystemobject")
For d = da To Date
For Each f In fso.getfolder(ThisWorkbook.Path).Files
If InStr(f.Name, Format(d, f_m)) > 0 Then MsgBox f.Name
Next f
Next d
End Sub
（mm） 2020/07/16(木) 10:54
mmさん、関数例ありがとうございます。
1回コレクションを取得して回せば実用範囲内の速度が出る気がしますね。
（みっきー） 2020/07/16(木) 11:43
1文字M,Dですが、ファイル名に普通にアルファベットが使われる可能性があるならば、フォーマット指定の方から除外するとか工夫しないと駄目でしょうね。（1文字Yは、判定から外して良いと思う） フォーマット指定中にMとあるのに、それは月じゃない、なんて判らないですから。
方法としては、フォーマット指定側を少し変えて、エスケープ文字を入れて書式ではないと明示するとか、|MM| のように、ファイル名には使えない記号で括って表現するとか、でしょうか。 または、フォーマット指定にはオリジナルの文字列ではなく、年月日部分以外はワイルドカードの「?」で指定しておき、イコールではなくLikeで比較するとか。
（???） 2020/07/16(木) 12:01
私のコード作成練習としてコードを書いてみました。
・検索文字列を一つ指定して、その結果を得るというスタイルにしている。 ・（３つのいずれかの条件を満たせば抽出するのか、問題設定がやや不明確だと感じた。）
以下にコードを示しますが、検証を十分したわけではないので、思わぬミスがあるやもしれない。 その意味で参考レベルとしておきます。
【前提】 ・検索文字列 アクティブシートのA1セルにあるものと仮定。（如何様にでも修正してください） ・検索対象 ThisWorkbook.Path配下のファイル群とした。 （これも同様） ・結果表示 イミディエイトウインドウにデバッグ出力 （これも同様）
【考え方】
(1)検索文字列:SampleYYYYMMDD.xlsx
・IsDate("YYYY/MM/DD")であればマッチと判定(擬似コードにつき注意）
(2)検索文字列:Sample_MMMDD.xlsx
・IsDate("MMM,DD")がTrueであればマッチと判定(擬似コードにつき注意）
(3)検索文字列:SampleYY年M月D日.xlsx
・??年*月*日部分を取り出し(sとする)、
・IsDate(s)がTrueであればマッチと判定
（なお、仮に Sample20200231.xlsx とか Sample_Feb31.xlsx とか Sample20年2月31日.xlsx とか があっても、それはIsDateで撥ねられるので、検索にヒットしません。 これもヒットさせたいということなら、年月日のチェックをはずして、 形式面でのチェックだけすることになる。）
【参考コード】 Option Explicit
Dim re2 As Object
Sub test()
Dim opt As String
Dim re As Object
Dim m As Object
Dim pat As Long
Dim fso As Object
Dim f As Object
Dim pre As String
Dim after As String
opt = [A1].Value '検索文字列がA1セルにあるとした。■適当に修正のこと
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "(?:^(.*?)(YYYYMMDD)(.*?)$)|(?:^(.*?)(MMMDD)(.*?)$)|(?:^(.*?)(YY年M月D日)(.*?)$)"
re.IgnoreCase = True
Set m = re.Execute(opt)
If m.count > 0 Then
Select Case True
Case m(0).SubMatches(1) <> Empty
pat = 1: pre = m(0).SubMatches(0): after = m(0).SubMatches(2)
Case m(0).SubMatches(4) <> Empty
pat = 2: pre = m(0).SubMatches(3): after = m(0).SubMatches(5)
Case m(0).SubMatches(7) <> Empty
pat = 3: pre = m(0).SubMatches(6): after = m(0).SubMatches(8)
End Select
pre = escape(pre) '正規表現の特殊文字列があればEscapeしておく
after = escape(after) '同上
End If
Set re2 = CreateObject("VBScript.RegExp")
re2.IgnoreCase = True
'ファイルを取得してチェック
Set fso = CreateObject("Scripting.filesystemobject")
For Each f In fso.getfolder(ThisWorkbook.Path).Files
If check(f.Name, pat, pre, after) Then Debug.Print f.Name
Next
End Sub
Function check(ByVal f$, ByVal pat&, ByVal pre$, ByVal after$) As Boolean
Dim m As Object
Dim s1$, s2$, s3$
Select Case pat
Case 1
re2.Pattern = pre & "(\d{4})(\d{2})(\d{2})" & after
Set m = re2.Execute(f)
If m.count > 0 Then
s1 = m(0).SubMatches(0)
s2 = m(0).SubMatches(1)
s3 = m(0).SubMatches(2)
If IsDate(s1 & "/" & s2 & "/" & s3) Then check = True
End If
Case 2
re2.Pattern = pre & "([A-Za-z]{3})(\d{2})" & after
Set m = re2.Execute(f)
If m.count > 0 Then
s1 = m(0).SubMatches(0)
s2 = m(0).SubMatches(1)
If IsDate(s1 & "," & s2) Then check = True
End If
Case 3
re2.Pattern = pre & "(\d{2}年\d{1,2}月\d{1,2}日)" & after
Set m = re2.Execute(f)
If m.count > 0 Then
s1 = m(0).SubMatches(0)
If IsDate(s1) Then check = True
End If
End Select
End Function
Function escape(s As String) As String
s = Replace(s, "\", "___") '仮文字に変換しておく
s = Replace(s, "*", "\*")
s = Replace(s, "+", "\+")
s = Replace(s, ".", "\.")
s = Replace(s, "?", "\?")
s = Replace(s, "{", "\{")
s = Replace(s, "}", "\}")
s = Replace(s, "(", "\(")
s = Replace(s, ")", "\)")
s = Replace(s, "^", "\^")
s = Replace(s, "$", "\$")
s = Replace(s, "-", "\-")
s = Replace(s, "-", "\-")
s = Replace(s, "-", "\-")
s = Replace(s, "|", "\|")
s = Replace(s, "/", "\/")
s = Replace(s, "___", "\\") '仮文字を\\に変換
escape = s
End Function
【おわりに】 言わずもがなだが。 前のスレッドでこのような言い方があった。 ＞(コード処理に組み込みますので、手でやったほうが早いというご回答はご遠慮ください) ＞Excel VBAに詳しい方のご回答がいただけると嬉しいです。 これは、 詮無い回答は最初からお断りします、自分より低レベルの人は回答しないで下さい、 と言っているように人によっては受け止めてしまう。 特に拒否している言葉につなげているので。
今回もそうだが、「VBAに詳しい方の回答」などと限定する必要はないのではないか。 もっとフラットに幅広に意見を聞いたらどうなのかと思う。
前のスレッドも、本来であれば色々コメントが付いてよいテーマだと思う。 結局はご自分が損をするので、少し考えられた方がよいという助言。 （γ ） 2020/07/16(木) 15:02
修正と補足です。
check の中で実行している一致判定が部分一致になってしまっているので、
以下のように完全一致に修正してください。（３ケースともです）
re2.Pattern = "^" & pre & "(\d{4})(\d{2})(\d{2})" & after & "$"
re2.Pattern = "^" & pre & "([A-Za-z]{3})(\d{2})" & after & "$"
re2.Pattern = "^" & pre & "(\d{2}年\d{1,2}月\d{1,2}日)" & after & "$"
なお、各ファイル毎に、正規表現のパターンを指定しているので、その点無駄とも言えますが、 さほど時間を要する処理とも思えないのと、 コード自体は単純になっている気がするので、このままにしておきます。
（γ ） 2020/07/16(木) 20:31
応用はできるものと想定。
Sub test()
Dim e, x, FoundFile As String
x = Array("Sample20年7月15日.xlsx", "Sample20200715.xlsx", "Sample_Jul15.xlsx")
For Each e In Array("SampleYYYYMMDD.xlsx", "Sample_MMMDD.xlsx", "SampleYY年M月D日.xlsx")
FoundFile = FindFile(e, x)
MsgBox IIf(Len(FoundFile), FoundFile, "No match") & " for " & e
Next
End Sub
Function FindFile(ByVal txt As String, x) As String
Dim sm As Object, temp As String, myMonth As String
Dim Pref As String, Suf As String, e
myMonth = "(" & Join([index(text(column(a:l)*29,"mmm"),,)], "|") & ")"
With CreateObject("VBScript.RegExp")
.Pattern = "^(.*?)(((Y{2}|Y{4})年?)?(M{1,2}月?|M{3})(D{1,2}日?))(.*)$"
If .test(txt) Then
Set sm = .Execute(txt)(0).submatches
If sm(4) <> "MMM" Then
temp = Replace(Replace(Replace(sm(1), "Y", "\d"), Replace(sm(4), "月", ""), "\d{1,2}"), Replace(sm(5), "日", ""), "\d{1,2}")
Else
temp = Replace(Replace(Replace(sm(1), "Y", "\d"), sm(4), myMonth), Replace(sm(5), "日", ""), "\d{1,2}")
End If
End If
.Pattern = "([$()^|\\\[\]{}+*.?-])"
Pref = .Replace(sm(0), "\$1")
Suf = .Replace(sm(6), "\$1")
.Pattern = "^" & Pref & temp & Suf & "$"
For Each e In x
If .test(e) Then FindFile = e: Exit For
Next
End With
End Function
（seiya） 2020/07/16(木) 22:22
修正：23:22
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.