複数のフォルダから指定するファイルをコピー

質問

こんばんは。宜しくお願いします。

◇行いたいこと
複数のフォルダ(例："D:\AB"　"D:\CD"　"D:\EF")に格納されているファイルの中から指定した
日付を含んだファイルをコピーし、あるフォルダに張り付けたい。
(指定する日付を含んだファイルがすべてのフォルダに存在するとは限らない)

◇現時点でのソース
※エラー処理の未実装部分については無視していただいてけっこうです。

Dim fs
Dim msg
Dim f
Const copyFrom = "D:\AB"
Const copyTo = "D:\VBS\コピー先\"

Do
'日付入力のインプットボックスを出力
hizuke = InputBox("日付を入力してください。" & vbCr & vbCr & "例）2000-01-01")
'インプットボックスの入力値が空白である
If hizuke = "" Then
'日付入力を促すメッセージ出力
MsgBox "日付を入力してください。"
Exit Do
End If
'インプットボックスの入力値が10文字である
If Len(hizuke) = 10 Then
'エラーが発生しても次の処理をすすめる
On Error Resume Next
'指定した日付の確認ダイアログを表示
msg = MsgBox(hizuke & "でよろしいですか？", vbYesNoCancel)
'日付の確認ダイアログでYesを選択
If msg = vbYes Then
'ファイルオブジェクトを作成
Set fs = CreateObject("Scripting.FileSystemObject")
'コピー元フォルダに存在するファイルを読み込む
For Each f In fs.GetFolder(copyFrom).Files
'指定した日付を含むファイル名を検索
If InStr(f.Name, hizuke) > 0 Then
'未実装　ファイルの上書き処理
fs.CopyFile 'コピー元　コピー先
Exit Do
'未実装　Else Ifの処理
End If
Next
'未実装　Else Ifの処理
End If
'未実装　Else Ifの処理
End If

Loop

以上です。ご教授宜しくお願いします。

回答No.2

DOUGLAS_ · ベストアンサー

こんな感じでイケルかと存じますが、内容をよく吟味してから、実情に応じてコードを書き換えてみてください。

Option Explicit

Dim fs, f, msg, copyFrom, c
Dim hizuke, hizuke8, hizuke8h, hizuke8p, hizuke6, hizuke6h, hizuke6p, h
Const copyTo = "D:\VBS\コピー先\"
copyFrom = Array("D:\AB", "D:\CD", "D:\EF")

'日付の確定
Do
     hizuke = InputBox("日付を入力してください。" & vbCr & vbCr & "例）2000-01-01")
     If hizuke = "" Then WScript.Quit
     If Len(hizuke) > 5 Then
         If Left(hizuke, 2) <> "20" Then hizuke = "20" & hizuke
         hizuke = Replace(hizuke, ".", "/")
         On Error Resume Next
         hizuke = FormatDateTime(hizuke, vbShortDate)
         If Err.Number = 0 Then
             If Year(hizuke) > 1999 Then
                 If MsgBox(FormatDateTime(hizuke, vbLongDate) & "でよろしいか？", vbYesNoCancel) = vbYes Then Exit Do
             End If
         End If
     End If
     On Error GoTo 0
Loop

'日付文字列の配列
hizuke8 = Replace(hizuke, "/", "")
hizuke8h = Replace(hizuke, "/", "-")
hizuke8p = Replace(hizuke, "/", ".")
hizuke6 = Mid(hizuke8, 3, 6)
hizuke6h = Mid(hizuke8h, 3, 8)
hizuke6p = Mid(hizuke8p, 3, 8)
hizuke = Array(hizuke8, hizuke8h, hizuke8p, hizuke6, hizuke6h, hizuke6p)

'該当するファイルのコピー
Set fs = CreateObject("Scripting.FileSystemObject")
For c = 0 To UBound(copyFrom)
     For Each f In fs.GetFolder(copyFrom(c)).Files
         For h = 0 To UBound(hizuke)
             If InStr(f.Name, hizuke(h)) > 0 Then
                 On Error Resume Next
                 fs.CopyFile f.Path, copyTo & f.Name, False
                 If Err.Number <> 0 Then
                     '同名のファイルが存在するときは、フォルダ名を冠して保存
                     fs.CopyFile f.Path, copyTo & Replace(Mid(copyFrom(c), 3, 100), "\", "") & "_" & f.Name, False
                 End If
                 On Error GoTo 0
             End If
         Next
     Next
Next
MsgBox "終了しました"

お礼

いつもありがとうございます。参考にさせていただきます(*^_^*)

回答No.1

bin-chan

で、何が不足なんでしょう？

・copyFrom を Constにしたら、D:\CD"　"D:\EF"に着手できない。
・せっかくFileSystemObject使ってるんだから、CopyFileメソッド使えば上書き可能。
とか？

お礼

出来ました。Array関数に複数のパスを入れ、ループでまわすことで行いたいことができました。
アドバイスありがとうございます。