VBAでフォルダ内の全てのｃｓｖファイルから直近3日間で作成されたファイルを判別しコピペ

Question

マクロ独学で勉強中です。
検索しましたが、下記コードしか自分では組めず、最終手段で質問いたします。
【やりたいこと】
1.フォルダ内のすべてのｃｖｓファイルの作成日時を確認。
2.現在の日付から直近三日間で作成されたファイルを判別。
3.判別されたcsvファイルを新規ファイルの1列目から順にコピー。

それぞれのcsvファイルにはA1からQ1までデータが入力されています。
フォルダ内にあるcsvファイル数は5000ほどあり、下記のマクロですべて取り込んでそこから日付で判別していくとなると時間がかかります。
（いちいち開いてこぴーしてるというのもあると思いますが、、、）
ちなみに、ｃｓｖファイルの名前は、”○○0414○○○.csv" みたいに一応日付がファイル名として記載されています。
このファイル名から判別できるとよりありがたいです。
（作成日時だと意図しないものもコピーされる恐れがあるため）

どなたかご教授いただければ幸いです。

Sub test()
Const FolderPath As String = "C:TestFolder"
Dim Filename As String
Dim Sh0 As Worksheet, Sh As Worksheet
Dim c As Long

Set Sh0 = ActiveSheet
Filename = Dir(FolderPath & "\*.csv")
Do Until Filename = ""
c = c + 1
Set Sh = Workbooks.Open(FolderPath & "\" & Filename).Sheets(1)
Sh.Range("A1:Q1").Copy Sh0.Range("A" & c & ":Q" & c)
Application.DisplayAlerts = False
Sh.Parent.Close
Application.DisplayAlerts = True
Filename = Dir()
Loop
End Sub

Qchan1962 · Accepted Answer

＃３＃５は独学中とのことですのであえて処理部分を分け、配列に入れています。ファイルのフルパスを取得する所で＃５の処理を入れても良いと思いますがエラー対策などの事もあるのでこのようロジックもなんとなく、、知っておいた方が良いと思います。横から失礼しますが、ちなみにご質問2のファイル名で操作する場合、＃３のコード Do While fileName <> ""　から　Loopまでを Do While fileName <> "" Set TrgFile = fso.GetFile(FolderPath & "\" & fileName) '該当ファイルを配列に入れる (ここの箇所で条件をファイル名のxxなどにする事などが出来ます ' If TrgFile.DateLastModified > DateAdd("d", -3, Now) Then If IsNumeric(Mid(fileName, 3, 4)) Then If Int(Mid(fileName, 3, 4)) >= Int(Format(Now() - 3, "mmdd")) Then ReDim Preserve Array_file(i) Array_file(i) = TrgFile.path i = i + 1 End If End If fileName = Dir() Loop のように書き換えると試してないので少し自信はないのですが、ファイル名の3文字目から7文字目に対応できると思います。コード内の不要なコメント行は、消してください。

めぐみん_ · Answer

＞Dim d1 As Date, d2 As Date, d3 As Date, dd As Date

宣言する型は日付型ではなく文字列型(As String)ではないでしょうか？

Qchan1962 · Answer

コピペでうっかり見逃していたのですが、、
Const FolderPath As String = "C:TestFolder"
は
Const FolderPath As String = "C:\TestFolder"
ですね。

めぐみん_ · Answer

初級者ジジィなので的外れも良い所かもですけど。
別の言語で該当するＣＳＶファイルを１つに纏め、そのファイルからエクセルに取り込めば宜しいのでは？
と希望内容を見ているとそう感じます。

とは言え他言語なんて『？』なジジィですので、カテゴリーを絞り込み過ぎない程度で質問をしてみるとか？

Qchan1962 · Answer

＃２＃３です
  Array_file配列には該当ファイルのフルパスが入るので
  ' 配列内のデータを取り出す（ここでファイルを開く処理）
の下部分から、、最後まではこんな感じで良いかと

Dim n As Long
    Dim wS As Worksheet
    Set wS = ActiveWorkbook.ActiveSheet
    
    For i = 0 To UBound(Array_file)
        n = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Application.ScreenUpdating = False
        With Workbooks.Open(Array_file(i))
            With ActiveSheet
                wS.Range(wS.Cells(n, 1), wS.Cells(n, 17)).Value = .Range(.Cells(1, 1), .Cells(1, 17)).Value
            End With
            .Close Savechanges:=False
        End With
        Application.ScreenUpdating = True
        '        Msg = Msg & Array_file(i) & vbCr
    Next
    ' 配列内のデータを取り出す--終わり
    Exit Sub
NothingFile:        '以降、該当ファイルが無い場合の処理
    MsgBox ("該当ファイルはありません")
End Sub

調べても分からない点がありましたら、補足かお礼で

fujillin · Answer

No1です。

＞一つずつ開いてするのは非効率
どうなさりたいのでしょうか？
どうするのが効率的とお考えなのでしょうか？

ご質問文にご提示のコードでは、フィルタもかけずに全部のファイルを開いてコピペしていますけれど、そこに関しては何のコメントも無いようです。
仮に、フィルタをかけるとして、それからどうしたいのでしょうか？

まぁ、CSVを全部読み込まずに、テキストとして最初の1行だけ読み込むという方法もあるとは思いますけれど、対象のCSVがどのような内容のものなのかにもよるでしょうし、そもそものご提示のコードがそのような方法はとっていませんでしたので・・・
いずれにしろ、ファイルを開いて読み込むことには変わりないはずです。
例えば、ScreenUpdatingを停止しておくことで、それなりに早くはなると思いますけれど・・・？

＞上記のコード追加して実行しましたが、延々ループとなってしまいました。
No1で提示した処理は、ループには直接関係がないものです。

ループを繰り返すのは、（多分）どこかループに関係のある制御を誤って変えてしまったものと想像されます。
例えば、
　Filename = Dir()
の1行を削除してしまったとか・・・？

Qchan1962 · Answer

つけ忘れ　テストプロシージャ
Sub TestSample()
    Const FolderPath As String = "C:TestFolder"
    Dim FileName As String, Extension As String
    Dim Array_file() As String
    Dim fso As Object, TrgFile As Object
    Dim Msg As Variant
    Dim i As Long
    Extension = ".csv"  '対象拡張子
    Set fso = CreateObject("Scripting.FileSystemObject")
    FileName = Dir(FolderPath & "\*" & Extension)
    Do While FileName <> ""
        Set TrgFile = fso.GetFile(FolderPath & "\" & FileName)
        '該当ファイルを配列に入れる 
'(ここの箇所で条件をファイル名のxxなどにする事などが出来ます
        If TrgFile.DateLastModified > DateAdd("d", -3, Now) Then
            ReDim Preserve Array_file(i)
            Array_file(i) = TrgFile.Path
            i = i + 1
        End If
        FileName = Dir()
    Loop
    Set TrgFile = Nothing
    '該当ファイルフルパスを配列に入れる--終わり

On Error GoTo NothingFile    '配列空用エラー対策
    ' 配列内のデータを取り出す（ここでファイルを開く処理）
    For i = 0 To UBound(Array_file)
        Msg = Msg & Array_file(i) & vbCr
    Next
    ' 配列内のデータを取り出す--終わり
    MsgBox Msg
    Exit Sub
NothingFile:        '以降、該当ファイルが無い場合の処理
    MsgBox ("該当ファイルはありません")

End Sub

Qchan1962 · Answer

こんにちは、
2のファイル名から判定する方法はすでに回答がありますので
1，の作成日の確認と更新日が3日以内のファイルを取得する方法です。
また、ご質問の背景は分かりませんが、ファイル名に日付以外の部分で
共通カテゴリー名などが付いていれば、更新日時から最新のファイルのみを抽出する事も可能と思います。
ファイルの作成日時や更新日時、アクセス日時を取得する方法は、
FileSystemObject(ファイルシステムオブジェクト)を使用します。
参考　http://officetanaka.net/excel/vba/filesystemobject/file02.htm
作成日時の場合は、DateCreatedプロパティを取得します。
更新日時の場合は、DateLastModified
アクセス日時の場合は、DateLastAccessed

下記は、フォルダー内にあるcsvファイルの更新日が3日以内のファイルpathをを取得するプロシージャです。（時間も関係するので仮要件）
取得できたファイルpathは配列に入れています。
（データ（取得）作成、メイン処理、出力処理を分けた方が良いかなと）

3，については
CSVファイルの扱いは色々なやり方があります。
多分サンプルで、１行のみをコピぺしているようですが、
そのままExcelで開いて文字列、値など問題のないCSVファイルなのでしょうか？また、範囲は1行のみなのでしょうか？
取敢えず
更新日が3日以内のファイルを取得する方法（時間も関係するので仮要件）

fujillin · Answer

こんにちは

ファイルをコピペする前に、日付でフィルターをかければよいだけのように思います。

＞このファイル名から判別できるとよりありがたいです
＞作成日時だと意図しないものもコピーされる恐れがある
とのことですが、ファイル名の規則がイマイチはっきりしないので・・・
「ファイル名の3～6文字目がmmdd形式の日付となっている」ものと仮定できる場合の一例を以下にあげておきます。

まず、事前に対象日を文字列として作成しておきます。
　d1 = Format(Now(), "mmdd")
　d2 = Format(Now() - 1, "mmdd")
　d3 = Format(Now() - 2, "mmdd")
そのうえで、ループ内で

dd = Mid(Filename, 3, 4)
　If dd = d1 Or dd = d2 Or dd = d3 Then
　　 ’　ここでファイルを開く処理
　End If
のようにすることで、対象のファイルだけを処理できるようになるでしょう。

※ ファイル名の規則が違うような場合は、判定方法をそれに合わせて変えればよいです。

VBAでフォルダ内の全てのｃｓｖファイルから直近3日間で作成されたファイルを判別しコピペ

＃３＃５は独学中とのことですのであえて

＞Dim d1 As Date, d2 As Date, d3 As Date, dd As Date

コピペでうっかり見逃していたのですが、、

初級者ジジィなので的外れも良い所かもですけど。

＃２＃３です

No1です。

つけ忘れ テストプロシージャ

こんにちは、

こんにちは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

つけ忘れ　テストプロシージャ