- ベストアンサー
サブフォルダを含めた最新のエクセルを取得したいです
VBA初心者です。 ①サブフォルダを含めた最新更新日のエクセルファイルを取得したいです。 ②そして、最新更新日のエクセルファイルは、そのエクセルが入っていたフォルダの名前に変更し、別フォルダへコピーしたいです。 お手数ですが、ご教授ください。
- みんなの回答 (5)
- 専門家の回答
質問者が選んだベストアンサー
xlsxに限定してみました。 Option Explicit Dim HitDate As Date Dim HitFile As String Dim HitPath As String Const Putfolder = "C:\testX" Sub sample() HitDate = 0 HitFile = "" GetFileName "C:\Users\papa\Desktop\MyTest\test" FileCopy HitPath, _ Putfolder & "\" & getLastPath(HitPath) & "." & getFileType(HitFile) End Sub Sub GetFileName(strPath As String) Dim tSfo As Object Dim tGf As Object Dim tFi As Object Dim tSub As Object Set tSfo = CreateObject("Scripting.FileSystemObject") Set tGf = tSfo.GetFolder(strPath) For Each tFi In tGf.Files If Right(tFi.Name, 5) = ".xlsx" Then '//この行を追加 If HitDate < tFi.DateLastAccessed Then HitDate = tFi.DateLastAccessed HitPath = tFi.Path HitFile = tFi.Name End If End If '//この行を追加 Next For Each tSub In tGf.SubFolders GetFileName tSub.Path Next End Sub '最下層のフォルダー名を取得 Function getLastPath(FPath As String) As String Dim HitPos As Long Dim WkStr1 As String Dim WkStr2 As String WkStr1 = FPath Do HitPos = InStr(1, WkStr1, "\") If HitPos = 0 Then Exit Do If HitPos > 0 Then WkStr2 = WkStr1 WkStr1 = Mid(WkStr1, HitPos + 1, Len(FPath)) End If Loop HitPos = InStr(1, WkStr2, "\") getLastPath = Mid(WkStr2, 1, HitPos - 1) End Function 'ファイルの拡張子を取得 Function getFileType(FName As String) As String Dim HitPos As Long Dim WkStr1 As String WkStr1 = FName Do HitPos = InStr(1, WkStr1, ".") If HitPos = 0 Then Exit Do If HitPos > 0 Then WkStr1 = Mid(WkStr1, HitPos + 1, Len(WkStr1)) End If Loop getFileType = WkStr1 End Function
その他の回答 (4)
- HohoPapa
- ベストアンサー率65% (455/693)
よかったら試してみてください。 サブフォルダーも含めて検索します。 また、エクセルファイル以外のファイルがあり、 それが最新であれば、そのファイルを複写しています。 もし、エクセルファイルだけに限定するのであれば 対象となる拡張子を限定列挙してください。 また、簡単な動作テストしか行っていません。 間違い、期待外の個所があれば指摘してください。 Option Explicit Dim HitDate As Date Dim HitFile As String Dim HitPath As String Const Putfolder = "C:\testX" Sub sample() HitDate = 0 HitFile = "" GetFileName "C:\MyTest\test" FileCopy HitPath, _ Putfolder & "\" & getLastPath(HitPath) & "." & getFileType(HitFile) End Sub Sub GetFileName(strPath As String) Dim tSfo As Object Dim tGf As Object Dim tFi As Object Dim tSub As Object Set tSfo = CreateObject("Scripting.FileSystemObject") Set tGf = tSfo.GetFolder(strPath) For Each tFi In tGf.Files If HitDate < tFi.DateLastAccessed Then HitDate = tFi.DateLastAccessed HitPath = tFi.Path HitFile = tFi.Name End If Next For Each tSub In tGf.SubFolders GetFileName tSub.Path Next End Sub '最下層のフォルダー名を取得 Function getLastPath(FPath As String) As String Dim HitPos As Long Dim WkStr1 As String Dim WkStr2 As String WkStr1 = FPath Do HitPos = InStr(1, WkStr1, "\") If HitPos = 0 Then Exit Do If HitPos > 0 Then WkStr2 = WkStr1 WkStr1 = Mid(WkStr1, HitPos + 1, Len(FPath)) End If Loop HitPos = InStr(1, WkStr2, "\") getLastPath = Mid(WkStr2, 1, HitPos - 1) End Function 'ファイルの拡張子を取得 Function getFileType(FName As String) As String Dim HitPos As Long Dim WkStr1 As String WkStr1 = FName Do HitPos = InStr(1, WkStr1, ".") If HitPos = 0 Then Exit Do If HitPos > 0 Then WkStr1 = Mid(WkStr1, HitPos + 1, Len(WkStr1)) End If Loop getFileType = WkStr1 End Function
- SI299792
- ベストアンサー率47% (772/1616)
画像の様に B1: 入力フォルダ B2: 出力フォルダ を指定して下さい。 1階層しか見ません。サブフォルダの下のフォルダは無視されます。 Option Explicit ' Sub Macro1() Dim Path As Object Dim FileName As String Dim MaxName As String Dim MaxDateTime As Date Dim NowDateTime As Date Dim Start1 As Integer Dim Start2 As Integer ' For Each Path In _ CreateObject("Scripting.FileSystemObject").GetFolder([B1]).SubFolders MaxDateTime = 0 FileName = Dir(Path.Path & "\*.xls*") ' Do While FileName > "" NowDateTime = FileDateTime(Path.Path & "\" & FileName) ' If MaxDateTime < NowDateTime Then MaxDateTime = NowDateTime MaxName = FileName End If FileName = Dir Loop ' If MaxDateTime > 0 Then Start1 = InStrRev(Path.Path, "\") + 1 Start2 = InStr(MaxName, ".") FileCopy Path.Path & "\" & MaxName, _ [B2] & "\" & Mid(Path.Path, Start1) & Mid(MaxName, Start2) End If Next Path End Sub
補足
ご回答いただき、ありがとうございます! やりたいことにかなり近いです! ただ、これを動かしますと、最新の更新日のxlsだけではなく、サブフォルダにある※xls全てが抽出されてしまいました。 最新更新日だけを抽出したいのですが、どうやったらできるのか、お手数ですが、ご教授願えませんでしょうか?
- imogasi
- ベストアンサー率27% (4737/17069)
VBA初心者には、すぐには、無理でしょう。 (1)ローカルのパソコンの、フォルダだけの話か? 最近は「クラウド」に、ファイルを置くのも多いようだが。 (2)VBAの学習分野ではあると思うが、VBScriptという分野がある。ファイル、フォルダ、サブフォルダなどを問題にするなら、VBSCRIPTの勉強をした方がよい。それには多少時間が掛かる。存在ぐらい知っているか?他に、DOSコマンド由来のDirなどをVBAでも使えるが、VBScriptでやる方が、すっきりすると思う。 (3)ファイル、フォルダ、サブフォルダの構成は、ツリー構造になっている。このことを知っているか?だから、それをたどるには、Recursiveの考えと、そのプログラムのやり方が出てくる。それでやるのが普通かもしれない。 しかしすぐには、難しいから、一番上の、エクセルファイルのありそうな、フォルダ名をまず掴む。その名前をシートの決めた列のセルに記録する。 そしてその1つのフォルダ名(親)について、その各フォルダ名の配下のフォルダ名(子)やファイル名(子)を、独立したモジュールの事項で、シートに書き上げる。 「深さ」(親ー子ー孫ー・・)は理論的に相当可能だが、子フォルダぐらいで、「葉」のファイル名に行き着くのではないかな。 (Googleで「木構造」で照会。根、ノード、葉、深さ、深さ優先などの術語の理解。) 中身を調べるだけなら(リカーシブなどの技法の習得を急がないなら)そういう方法を勧める。 ーー むしろ、上記のような構造を「ノード」名を図示(表示)してくれるソフトを探して、使ってはどうか。 Googleで「ファイル ツリー表示 ソフト」で照会。Vectorなどにそういうソフトがある。 またコードについても、Googleで「VBA ファイル ツリー表示」で照会したら記事がある。 ーー 質問者の、今の一番の問題点は、そういう照会を、まずしよう、それでまず勉強しようと、してないことにあると思う。WEBには、ほとんどの問題の解説とコードが見つかると思って探すべきだ。 質問コーナーの回答に安直に頼るな。 ーーー Googleで「VBA ファイル Recursive」で照会。 最初の記事 https://excel-vba.work/2020/10/30/%E3%80%90vba%E3%80%91%E3%80%90%E5%86%8D%E5%B8%B0%E3%80%91%E6%8C%87%E5%AE%9A%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E9%85%8D%E4%B8%8B%EF%BC%88%E3%82%B5%E3%83%96%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80/ VBA】【再帰】指定フォルダ配下(サブフォルダ含む)の全てのExcelファイルに対して、処理を行う
- tkf-
- ベストアンサー率58% (821/1398)
会社のファイルサーバーなどで管理されているのでしょうか。 VBAでゴリゴリ組むことも可能かもしれませんが、そのフォルダの管理方法について管理者の方とご相談されたほうがいいのではと思います。 ・最新版を意識しないで済み、過去バージョンなど履歴が保存できる仕組み ・プログラムで組みたいのであれば、それがしやすいように あなたがいなくなったらメンテできない仕組みを作るべきではないです。
補足
ありがとうございます。 拡張子は、.xlsxです。他のファイルは、対象外にしたいです。 お手数ですが、宜しくお願いします!