excel2003でのファイル検索VBA

質問

当方excel2003利用者です。

今回、Aというフォルダにある拡張子png且つファイルサイズ2000KB以上且つ更新日が過去1週間以内のものを検索、抽出し、Bというフォルダにコピーさせるマクロを作りたいと考えています。

現在Dir関数、Filelen関数、FileDateTime関数を組み合わせて試行錯誤していますがうまくいきません。

参考例を教えていただけないでしょうか？

宜しくお願いいたします。

回答No.3

Wendy02 · ベストアンサー

FileSystemObject のMoveFileのメソッドの方が確かですから、こちらを使いました。
また、余計かもしれませんが、この内容は特に、Excelを使わなくても良いのではないかと思います。つまり、WScript で、Filelen, FileDateTime は、それぞれ、Size, LastModifiedDate のプロパティに換えます。一旦、アンチウィルスで通してあげれば、使えるようになります。

'//
Sub Test1()
　Dim objFS As Object
　Dim srcDir As String
　Dim dstDir As String
　Dim oDate As Date
　Dim fn As String
　Dim i As Long
　oDate = Date - 7 '一週間前(7日)
　Set objFS = CreateObject("Scripting.FileSystemObject")
　Const EXT As String = ".png"
　Const LIMITSIZE As Integer = 20
　srcDir = "A\" '←必ず最後に'\'を入れる 'ソース
　dstDir = "B\" '←必ず最後に'\'を入れる 'コピー先
　fn = Dir(srcDir & "*" & EXT, vbNormal)
　Do While fn <> ""
　　If fn <> "." And fn <> ".." Then
　　　If FileLen(srcDir & fn) > LIMITSIZE And FileDateTime(srcDir & fn) >= oDate Then
　　　　On Error Resume Next
　　　　objFS.MoveFile srcDir & fn, dstDir
　　　　On Error GoTo 0
　　　　i = i + 1
　　　End If
　　End If
　　fn = Dir
　Loop
　MsgBox i & " 個のファイルを移動しました。", vbInformation
　Set objFS = Nothing
End Sub

回答No.4

Wendy02

#3の訂正です。
質問を読み間違えました。移動だと思ったのですが、コピーでしたので、

　　　　On Error Resume Next
　　　　objFS.MoveFile srcDir & fn, dstDir
　　　　On Error GoTo 0
　　　　　　　　↓

　　　　On Error Resume Next
　　　　objFS.CopyFile srcDir & fn, dstDir
　　　　On Error GoTo 0
と変えます。
それと、
　　　　Const LIMITSIZE As Integer = 20
　　　　　　　　↓
　　　　Const LIMITSIZE As Integer = 2000　'ファイルサイズ

に書き換えてください。

お礼

ありがとうございました！！

回答No.2

hananoppo

こんな感じでどうでしょう。

Sub PngCopy()
Dim Path1 As String, Path2 As String
Dim FileName As String

Path1 = "C:\A\"
Path2 = "C:\B\"
FileName = Dir(Path1 & "*.png")
Do Until FileName = ""
If FileLen(Path1 & FileName) >= 2048000 And FileDateTime(Path1 & FileName) >= Date - 7 Then
FileCopy Path1 & FileName, Path2 & FileName
End If
FileName = Dir()
Loop
End Sub

回答No.1

hallo-2007

試行錯誤されていることなので、別の観点からアドバイスです。
以下のマクロを新しいシートの上で実行してみてください。
Sub ボタン1_Click()
Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", ThisWorkbook.Path)
Set FS = CreateObject("Scripting.FileSystemObject")
Set Fol = FS.GetFolder(Target)
Set Fil = Fol.Files
Rows("3:65536").ClearContents
i = 3
For Each Fx In Fil
'ファイル名の書き出し
Cells(i, 2) = Fx.Name
'ファイルのサイズ
Cells(i, 3) = Fx.Size
'最終更新日
Cells(i, 4) = Fx.DateLastModified
i = i + 1
Next
End Sub
後は、IF分なりで抽出できると思いますし、必要なファイルをBフォルダーへコピーすればよいです。
私流かもしれませんが、ファイルの操作の場合は
１、Bフォルダーのファイルの削除（クリア）のボタン（必要ならば）
２、Aフォルダーの必要なファイルの一覧の作成
３、一覧で取得したファイルのコピー
４、確認のためのBフォルダーのファイルの一覧表示
とボタンを複数作成して操作した方が間違いやとんでもない失敗をしなくてすみます。