プロが教えるわが家の防犯対策術!

あるフォルダに他システムより定時間毎にエクセルファイル(.xlsx)が任意の名前で保存され蓄積されていきます
その中から更新日時の期間を指定(日時~日時)して該当するファイル全てを指定のフォルダへ転送するエクセルマクロを御教示いたたけると幸いです
宜しくお願いします

A 回答 (3件)

No1です。


No1に提示された仕様でマクロを作成しました。標準モジュールへ登録してください。
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Option Explicit
Public Sub ファイル移動()
Dim sh As Worksheet '管理シート
Dim fromF As String '監視フォルダ
Dim toF As String '移動先フォルダ
Dim sdate As Variant '開始日(yyyy/mm/dd)
Dim edate As Variant '終了日(yyyy/mm/dd)
Dim stime As Variant '開始時刻(hh:mm:ss)
Dim etime As Variant '終了時刻(hh:mm:ss)
Dim fname As String 'ファイル名
Dim fpath As String 'ファイルパス名
Dim ftime As Date 'ファイル更新日時
Dim s_ftime As Date '開始日時
Dim e_ftime As Date '終了日時
Dim cnt As Long 'ファイル件数
Dim files() As String '移動対象ファイルの配列
Dim fileNames As String '移動対象ファイルの一覧
Dim ans As Long
Dim i As Long
Set sh = Worksheets("管理")
fromF = sh.Cells(1, "B").Value
toF = sh.Cells(2, "B").Value
toF = sh.Cells(2, "B").Value
sdate = sh.Cells(3, "B").Value
stime = sh.Cells(4, "B").Value
edate = sh.Cells(5, "B").Value
etime = sh.Cells(6, "B").Value
If Dir(fromF, vbDirectory) = "" Then
MsgBox ("監視フォルダエラー")
Exit Sub
End If
If Dir(toF, vbDirectory) = "" Then
MsgBox ("移動先フォルダエラー")
Exit Sub
End If
If sdate = "" Then
sdate = Date
End If
If edate = "" Then
edate = Date
End If
If sdate > edate Then
MsgBox ("日付指定エラー")
Exit Sub
End If
If sdate = edate And stime > etime Then
MsgBox ("時刻指定エラー")
Exit Sub
End If
s_ftime = sdate + stime
e_ftime = edate + etime
cnt = 0
' 先頭のファイル名の取得
fname = Dir(fromF & "\*.xlsx", vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While fname <> ""
ftime = FileDateTime(fromF & "\" & fname)
'そのファイルの更新時刻が、指定された開始時刻~終了時刻なら移動する
If ftime >= s_ftime And ftime <= e_ftime Then
ReDim Preserve files(cnt)
files(cnt) = fname
cnt = cnt + 1
fileNames = fileNames & vbLf & fname
End If
' 次のファイル名を取得
fname = Dir()
Loop
If cnt = 0 Then
MsgBox ("移動対象ファイルなし")
Exit Sub
End If
ans = MsgBox(cnt & "件の移動対象ファイルがあります。移動しますか?" & fileNames, vbOKCancel)
If ans <> vbOK Then Exit Sub
For i = 0 To cnt - 1
fname = files(i)
fpath = toF & "\" & fname
'移動先に同一ファイルが存在するなら削除する
If Dir(fpath) <> "" Then
Kill fpath
End If
'ファイルの移動
Name fromF & "\" & fname As fpath
Next
MsgBox ("ファイル移動完了")
End Sub
-----------------------------------------

不具合、不明点があれば補足ください。
    • good
    • 0
この回答へのお礼

ありがとうございます
こんな短時間で感服しました
フォルダ及びご提案頂いたEXCELファイル作成し早速試してみました、日付の書式の部分で若干躓きましたが
問題なく出来ました
勉強になりますシンプルなので
正規のフォルダ設定し本番に使わせていただきます

お礼日時:2017/02/25 21:31

以下で、設定の仕方がわかれば、使いこなせるかと思います。


一通りのエラー処理はしてあります。
しかし、今は、同名ファイルに関しては、エラーを出して終わるだけにとどまっています。

なお、設定部分だけ、シートに持ってきても良いかとは思います。それは、おまかせします。

'// 標準モジュール
Sub RangeDatesSpecializing()
 Dim FTime As Variant
 Dim LTime As Variant
 Dim fDate As Variant
 Dim i As Long, j As Long
 Dim FName As String, tmp
 Dim Aryfiles() As String
 Dim objFS As Object
 Dim mPath As String
 Dim Destin As String
 Dim Ext As String
 Dim f As Variant
 On Error GoTo ErrHandler
 '****************************
 'ソース元
 mPath = "C:\Users\Temp1\"
 '移動先
 Destin = "C:\Users\Temp2\Excelfiles\"
 FTime = "2016/04/01 00:10" '初め
 LTime = "2016/04/28 0:00" '終わり
 '拡張子
 Ext = ".xlsx"
 '**************************
 '------------Error Check 開始 ----------
 If Right$(Destin, 1) <> "\" Then Destin = Destin & "\"
 If Right$(mPath, 1) <> "\" Then mPath = mPath & "\"
 If Dir(mPath, vbDirectory) = "" Then MsgBox "フォルダーが存在していません。", vbExclamation: Exit Sub
 If Dir(Destin, vbDirectory) = "" Then MsgBox "フォルダーが存在していません。", vbExclamation: Exit Sub
 FTime = CDate(FTime)
 LTime = CDate(LTime)
 If FTime > LTime Then
  tmp = LTime: LTime = FTime: FTime = tmp
 End If
 If Ext = "" Then MsgBox "拡張子が記入されていません。", vbExclamation: Exit Sub
 If Left$(Ext, 1) <> "." Then Ext = "." & Ext
 '---------Error Check 終了 -----------------
 Set objFS = CreateObject("Scripting.FilesystemObject")
 ReDim Aryfiles(1000)
 FName = Dir(mPath & "*" & Ext, vbNormal)
 Do While FName <> ""
  If FName <> "." And FName <> ".." Then
   If (GetAttr(mPath & FName) And vbNormal) = vbNormal Then
    fDate = objFS.GetFile(mPath & FName).DateLastModified
    If fDate >= FTime And LTime >= fDate Then
     Aryfiles(i) = FName
     i = i + 1
     If i > 1000 Then MsgBox "取扱ができません", vbCritical: Exit Sub
    End If
   End If
  End If
  FName = Dir
 Loop
 If i > 0 Then
  ReDim Preserve Aryfiles(i - 1)
  For Each f In Aryfiles
   ' On Error Resume Next
   objFS.MoveFile mPath & f, Destin
   'On Error GoTo 0
   j = j + 1
  Next f
  Else
  MsgBox "ファイルが見つかりません", vbExclamation
 End If
ErrHandler:
 If Err.Number Then
  MsgBox Err.Number & ": " & Err.Description & vbCrLf & _
  "ファイルの移動に失敗しました。", vbExclamation
 ElseIf j > 0 Then
  MsgBox "ファイルの移動" & j & "個が完了しました", vbInformation
 End If
 
 Set objFS = Nothing
End Sub
'//
    • good
    • 0
この回答へのお礼

ありがとうございます
設定の仕方について確認しフォルダ設定を変更して試してみました
問題なく動作しました
エラーの処理設定 の部分は特に参考になりますありがとうございました

お礼日時:2017/02/25 21:36

添付の図のようにシート名:"管理"のシートに


B1にエクセルファイルが書き込まれるフォルダ
B2に移動先のフォルダ
B3に開始指定日時の日付(年月日)
B4に開始指定日時の時刻(時分秒)
B5に終了指定日時の日付(年月日)
B6に終了指定日時の時刻(時分秒)
を記入し、マクロが実行されたとき、
excelファイルの更新時刻が開始指定日時~終了指定日時の範囲内であれば、そのファイルを移動先へ転送するようにします。
尚、”他システムより定時間毎にエクセルファイル(.xlsx)が任意の名前で保存され蓄積されていきます”
ということなので、マクロが毎日実行されることを考慮し、
B3とB5の日付は空白の場合、マクロが実行された当日の日付を採用するようにします。
(もちろん、日付が指定された場合はその日付に従います)

上記のような仕様でいかがでしょうか。
「あるフォルダに他システムより定時間毎にエ」の回答画像1
    • good
    • 0
この回答へのお礼

ありがとうございました
仕様を分かりやすくまとめて頂き
マクロの記述のイメージが沸いています、具体的な記述がどうなるか考えてみます

お礼日時:2017/02/25 18:50

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!