EXCELのVBAでフォルダ内のファイル名抽出方法

お世話になります。
以前同じ質問で回答頂いた後締め切ってしまったのですが、別の課題が出てきてしまったので、詳しい方がいらっしゃいましたら補足回答お願い致します。(考えてみたのですが複雑でよく分かりませんでした)
以前の質問
https://oshiete.goo.ne.jp/qa/8953548.html
フォルダ内の中からタイトル別,ファイル(拡張子)別に最新のファイルを取り出したいという内容だったのですが、もう一つ条件が追加増えた場合、どうすればいいでしょうか。
--------------------------------　　　
(フォルダ内)
TitleA01.xls　TitleB01.doc
TitleA02.xls　TitleB02.doc
TitleA03.xls　TitleB03.doc
TitleA01.doc　TitleB04.doc
TitleA02.doc　TitleB01.xls
--------------------------------
　　　　　　↓(条件が追加)
--------------------------------
(フォルダ内)
TitleA_A_01.xls　 TitleB_A_01.xls
TitleA_A_02.xls　 TitleB_A_02.xls
TitleA_B_01.xls　 TitleB_B_01.xls
TitleA_B_02.xls　 TitleB_B_02.xls
TitleA_A_01.doc　 TitleB_A_01.doc
TitleA_A_02.doc　 TitleB_B_02.doc
--------------------------------
上記の様にファイル名にTitleA,Bとは別に_A_と_B_がある場合、TitleAとB別に最新ファイルを取り出したい場合はどうすればいいでしょうか。すこし複雑だと思いますが、詳しい方よろしくお願い致します。(今回の出力したい結果(TitleAであれば)はTitleA_A_02.xls,TitleA_B_02.xls,TitleA_A_02.doc)

質問者からの補足コメント

• 再び有難うございます！一度締切りしたので、しまった！と思っていました。感謝です。
  ＞For Each m In Array("TitleA_A", "TitleA_B", "TitleB_A", "TitleB_B")
  とありますが、Title名はその都度変わる場合でTitleAとTitleBは1つずつ(条件(Title名)によって)取り出す場合はどのようにソースに変数として入れればいいのでしょうか？
  イメージですが変数名をHENSU(セルに入れた値)とすると、For Each m In Array(HENSU & "_A", HENSU & "_B")という形にしたのですが、うまく行きませんでした。
  度々すみませんが、よろしくお願い致します。

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/04/04 23:40

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/04/04 14:50

こんにちは。

今度は、シートに書き出すことにしました。

>今回の出力したい結果(TitleAであれば)はTitleA_A_02.xls,TitleA_B_02.xls,TitleA_A_02.doc)
拡張子と、TitleA_A とTitleA_Bとを分けるということでしょうか。たんなる組合せのようですから、後は、ご自身で書き入れてください。今回は、スピードを重視するために、予めオブジェクトにデータを格納しました。

以下のコードですと、TitleA と TitleB だけの分類なら、
　For Each n In Array(".doc", ".xls") 'ピリオドは必ず入れる
　For Each m In Array("TitleA", "TitleB")

これでよいし、そのファイル名を細分化するなら、このようになるはずです。

　For Each n In Array(".doc", ".xls") 'ピリオドは必ず入れる
　For Each m In Array("TitleA_A", "TitleA_B", "TitleB_A", "TitleB_B")
　　GetLastFile m & "*", n
　Next
Next

もちろん、もっと細分化するなら、ループをさらに増やすという方法もありますが、二段目で書き出せるなら、今のままでよいと思います。それ以上は、シートに該当ファイル全部を書き出して、フィルターにした方が早いかもしれません。

'//
Private Fso As Object　'モジュールの最上端に入れる
Private oFiles As Object
Sub GetLatestFileName()
Dim n As Variant
Dim m As Variant
Dim sPath As String
sPath = "C:\Temp\" '検索対象フォルダ・必ず最後は￥をつける
Set Fso = CreateObject("Scripting.FileSystemObject")
Set oFiles = Fso.GetFolder(sPath).Files
　Range("A1").CurrentRegion.Clear　'空のシートを用意してください。
　For Each n In Array(".doc", ".xls") 'ピリオドは必ず入れる
　For Each m In Array("TitleA_A", "TitleA_B", "TitleB_A", "TitleB_B")
　　GetLastFile m & "*", n
　Next
Next
Set oFiles = Nothing
Set Fso = Nothing
End Sub

Sub GetLastFile(ByVal fFN As String, ByVal Ext As String)
　Dim objFiles As Object
　Dim f As Variant
　Dim i As Long, j
　Dim r As Variant
　Dim Ar() As Variant
　Dim buft As Date, bufn As String
　fFN = StrConv(fFN, vbLowerCase)
　Ext = StrConv(Ext, vbLowerCase)
　j = Len(Ext)
　buft = 0 : bufn =""
　　For Each f In oFiles
　　　If Trim(f.Name) <> "" And _
　　　　StrConv(f.Name, vbLowerCase) Like fFN And _
　　　　StrConv(Right(f.Name, j), vbLowerCase) Like Ext Then
　　　　If f.DateLastModified > buft Then
　　　　　buft = f.DateLastModified
　　　　　bufn = f.Name
　　　　End If
　　　End If
　　Next f
　If bufn <> "" Then
　　j = Cells(Rows.Count, 1).End(xlUp).Row + 1
　　Cells(j, 1).Value = bufn
　　Cells(j, 2).Value = buft
　End If
End Sub
　'//

この回答へのお礼

お礼遅くなり申し訳ございません。無事に目的達成できました。2回に渡る回答大変感謝しています。
有難うございました！！

お礼日時：2015/04/17 18:44

No.5 回答者： 30246kiku 回答日時： 2015/04/09 12:50

解決されていましたらスルーしてください

ファイル名が　TitleA_A_01.xls　なら、
・xls の
・TitleA_A_　のグループ
（ファイル名の後ろ数字部分を削除したもの）
と解釈します。

出力は、A列には拡張子/グループ順、B列には更新日時、とします。
以下 ★ 部分のフォルダを変更後実行してみてください。

やっている事は、ファイルを　Dictionary の３段構成で管理
１段目キー：拡張子を小文字にしたもの
２段目キー：ファイル名の後ろ数字を削除して小文字にしたもの
３段目キー：0 固定　
　値は、ファイル名、更新日時、ファイル名後ろの数字、を配列にしたもの


Public Sub Samp1()
　　Dim dic As Object, v As Variant
　　Dim vK1 As Variant, vK2 As Variant, vD As Variant
　　Dim sR As String
　　Dim i As Long, j As Long, k As Long
　　Const CPATH As String = "D:\Hogehoge\hoge" ' ★ 対象フォルダ

　　Set dic = CreateObject("Scripting.Dictionary")
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each v In .GetFolder(CPATH).Files
　　　　　　vK1 = LCase(.GetExtensionName(v.Name))
　　　　　　If (Not dic.Exists(vK1)) Then
　　　　　　　　dic.Add vK1, CreateObject("Scripting.Dictionary")
　　　　　　End If
　　　　　　vK2 = LCase(CutNum(.GetBaseName(v.Name), sR))
　　　　　　If (Not dic(vK1).Exists(vK2)) Then
　　　　　　　　dic(vK1).Add vK2, CreateObject("Scripting.Dictionary")
　　　　　　　　dic(vK1)(vK2)(0) = Array(v.Name, v.DateLastModified, sR)
　　　　　　Else
　　　　　　　　vD = dic(vK1)(vK2)(0)
　　　　　　　　If (vD(1) < v.DateLastModified) Then
　　　　　　　　　　dic(vK1)(vK2)(0) = Array(v.Name, v.DateLastModified, sR)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With

　　If (dic.Count > 0) Then
　　　　i = 1
　　　　For Each vK1 In mySort(dic.Keys)
　　　　　　For Each vK2 In mySort(dic(vK1).Keys)
　　　　　　　　Cells(i, "A").Resize(, 2) = dic(vK1)(vK2)(0)
　　　　　　　　i = i + 1
　　　　　　Next
　　　　Next
　　　　Columns.AutoFit
　　End If
　　Set dic = Nothing
End Sub

Private Function CutNum(sS As String, sR As String) As String
　　Dim i As Long

　　For i = Len(sS) To 1 Step -1
　　　　If (Mid(sS, i, 1) Like "[!0-9０-９]") Then Exit For
　　Next
　　If (i = 0) Then i = Len(sS)
　　sR = StrConv(Mid(sS, i + 1), vbNarrow)
　　CutNum = Left(sS, i)
End Function

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) > vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function


※ 上記は、拡張子/ファイル名パターンに制限を設けていません
拡張子は、例えば doc, xls だけに
ファイル名の始まりは、例えば title_a, title_b だけに
制限したい場合は、以下部分を変更してみてください
（以下は結果表示時に制限するものになってます）
（覚える時に制限かけても良いと思います）

>　　　　For Each vK1 In mySort(dic.Keys)
>　　　　　　For Each vK2 In mySort(dic(vK1).Keys)
>　　　　　　　　Cells(i, "A").Resize(, 2) = dic(vK1)(vK2)(0)
>　　　　　　　　i = i + 1
>　　　　　　Next
>　　　　Next

↓

　　　　For Each vK1 In mySort(dic.Keys)
　　　　　　For Each v In Array("doc", "xls")
　　　　　　　　If (vK1 = v) Then Exit For
　　　　　　Next
　　　　　　If (Not IsEmpty(v)) Then
　　　　　　　　For Each vK2 In mySort(dic(vK1).Keys)
　　　　　　　　　　For Each v In Array("title_a", "title_b")
　　　　　　　　　　　　If (vK2 Like v & "*") Then Exit For
　　　　　　　　　　Next
　　　　　　　　　　If (Not IsEmpty(v)) Then
　　　　　　　　　　　　Cells(i, "A").Resize(, 2) = dic(vK1)(vK2)(0)
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　Next

※ vK1, vK2 では、半角は小文字で管理しているので Array 内は小文字？で･･･


※※ > 最新のファイル
が更新日時ではなく、ファイル名の最後にある数値部分の大きいものなら
以下部分を変更してみてください

>　　　　　　Else
>　　　　　　　　vD = dic(vK1)(vK2)(0)
>　　　　　　　　If (vD(1) < v.DateLastModified) Then
>　　　　　　　　　　dic(vK1)(vK2)(0) = Array(v.Name, v.DateLastModified, sR)
>　　　　　　　　End If
>　　　　　　End If

↓

　　　　　　Else
　　　　　　　　vD = dic(vK1)(vK2)(0)
　　　　　　　　If (Val(vD(2)) < Val(sR)) Then ' この判別が違うだけ
　　　　　　　　　　dic(vK1)(vK2)(0) = Array(v.Name, v.DateLastModified, sR)
　　　　　　　　End If
　　　　　　End If

に、
この場合でも、B列にはそのファイルの更新日時が表示されます。

この回答へのお礼

とても参考になります。有難うございました！

お礼日時：2015/04/17 18:46

No.4 回答者： cj_mover 回答日時： 2015/04/06 10:34

＃３です、＃３に関するこちらからの補足です。

一連の流れから、例示のファイル名については、
文脈として"A"や"B"は数字ではないと解釈していましたが、
"A"や"B"の部分に、もしも、数字が含まれている場合は、
＃３の記述では、うまく機能させることが出来ません。
＃３で意図したように
　"Title"の部分だけ指定してやれば、
　「ファイル名から付番を除いたタイトル」毎、各種「拡張子」毎
　に、「付番」が一番大きいファイル名を返す
ようなものを作るには、
"Title"や"A"や"B"の各部分が、どんな内容なのか、という情報が
必要になります。

ファイル名の例示にある"Title"や"A"や"B"の各部分に、
数字は含まれない、ということが確認できるようでしたら、
＃３のままでも十分機能します。

No.3 回答者： cj_mover 回答日時： 2015/04/06 09:21

こんにちは。

> Title名はその都度変わる
ファイルの名前の命名規則が管理できていない状態から実行することもある、
ということなのでしょうから、
"Title"の部分だけ指定してやれば、
"TitleA", "TitleA_A_", "TitleA_B_", "TitleB", "TitleB_A_", "TitleB_B_"
など、
"Title"で始まるファイルすべてについて
　●「ファイル名から付番を除いたタイトル」　毎、
　●各種「拡張子」　毎
に整理して、
　●「付番」が一番大きいファイル名
を返すようなものを書きました。
必然的に戻り値は配列になりますので、
とりあえず、
結果を（アクティブシートの）Ｂ列に出力するように書きましたが、
他の用途であれば、arrReturn()の中身を参照してください。

取得したファイル名を、どう使うのか、出力方法を書いた方が、
適切な答えが得易いですし、こちらも答え易いのですけれども、、、。
応用に躓くことがあれば、キチンと補足してください。

それから、前スレでも途中から話が難しくなっていますけれど、
> タイトル毎の最新ファイル(TaitleAであれば03のファイル名を、TitleBであれば04)のファイル名を取得したいのですが、
これって、ファイルに含まれている付番を対象に、
"02"より"03"が新しい、とか、
"01","02","03","04" の中で【最新ファイル】は"04"、とか、
とにかくファイル名を基準にしている、という理解で私は一貫しているのですが、
> 最新のファイルを取り出したい
と、今回少し表現が変わっていますが、
他の回答者さんがお示しになっていらっしゃる「最終更新日」
を基準に【最新ファイル】を決めるということなのでしょうか？
混乱があるので整理してみてください。

とりあえず、
「指定フォルダ」と「タイトル」の指定を変更してから、
Ｂ列が空になっているシートをアクティブにして、
実行すれば、結果を返すように書いてあります。

' ' ///

Sub Re8956109Gdict()

Dim oDict As Object　'　As Scripting.Dictionary
Dim oRegExp As Object　'　As VBScript_RegExp_55.RegExp
Dim colMatch As Object　'　As VBScript_RegExp_55.MatchCollection
Dim arrReturn()
Dim sDir As String
Dim sTitleHead As String
Dim sTemp As String
Dim sKey As String

　　' ' 「指定フォルダ」へのパスをドライブ名から指定
　　sDir = "D:\Work"
　　' ' ファイル名を前方一致で篩に掛ける「タイトル」を指定
　　sTitleHead = "Title"
' ' ■■■■　以上、要指定　■■■■

　　Set oDict = CreateObject("Scripting.Dictionary")
　　Set oRegExp = CreateObject("VBScript.RegExp")
　　oRegExp.Global = True
　　oRegExp.Pattern = "^(" & sTitleHead & "\D+)\d*.*(\.\D+)$"

　　' ' Dir関数でファイル名を取得
　　sTemp = Dir(sDir & "\" & sTitleHead & "*.*")
　　' ' Dir関数をループ
　　Do While sTemp <> ""　'　Dir関数でファイル名を取得し尽したらループ終了
　　　　' ' ファイル名を「タイトル」前方一致でパターンマッチング
　　　　Set colMatch = oRegExp.Execute(sTemp)
　　　　If colMatch.Count Then　'　「タイトル」前方一致でマッチすれば、
　　　　　　' ' キーを合成　＝　「ファイル名から付番を抜いた名前」 & "*" & 「拡張子」
　　　　　　sKey = colMatch(0).SubMatches(0) & "*" & colMatch(0).SubMatches(1)
　　　　　　' ' キーを基準に　アイテムを「ファイルの付番」が大きいものへ更新
　　　　　　If sTemp > oDict(sKey) Then oDict(sKey) = sTemp
　　　　End If
　　　　sTemp = Dir()　'　Dir関数で次のファイル名を取得
　　Loop

' ' ■■■■　以下、出力先、出力内容、要指定　■■■■
'　　arrReturn() = oDict.Keys　'　キーを配列に格納
'　　Cells(1, "A").Resize(oDict.Count).Value = Application.Transpose(arrReturn())　'　キー配列をセル範囲に出力

　　arrReturn() = oDict.Items　'　アイテム（ファイル名）を配列に格納
　　' ' アイテム（ファイル名）配列をセル範囲に出力
　　Cells(1, "B").Resize(oDict.Count).Value = Application.Transpose(arrReturn())

End Sub

' ' ///

この回答へのお礼

とても参考になります。有難うございました！

お礼日時：2015/04/17 18:47

No.2 回答者： WindFaller 回答日時： 2015/04/05 17:51

こんにちは。

>イメージですが変数名をHENSU(セルに入れた値)とすると、For Each m In Array(HENSU & "_A", HENSU & "_B")という形にしたのですが、うまく行きませんでした。

それでうまく行きませんか？基本的には間違いありません。
今試してみました。

Private Fso As Scripting.FileSystemObject
Private oFiles As Object

Sub GetLatestFileName()
Dim n As Variant
Dim m As Variant
Dim sPath As String
Dim HENSU1 As String
Dim HENSU2 As String

HENSU1 = Range("D1").Value　'出力する場所の同じシート上
HENSU2 = Range("E1").Value
・
・
For Each m In Array(HENSU1 & "_A", HENSU1 & "_B", HENSU2 & "_A", HENSU2 & "_B")
・
これで取れました。