筆箱にVBAのカンニングペーパーを入れる係のみすくです。こんにちは。
Excelのシート上に、
格納先のファイルパスとワイルドカードを使った条件を書いておいて、
条件にマッチしたらフォルダに格納。
MSDNのリファレンスによると、
「注釈: Microsoft Windows では、Dir で複数の文字 ( \* ) と 1 文字 ( ?) のワイルドカードを使用して、複数のファイルを指定できます。Macintosh では、これらの文字は有効なファイル名の文字と見なされ、複数のファイルを指定するためのワイルドカードとしては使用できません。」
Public Sub main() copyFilesByRule ("D:\Test\src") End Sub '--------------------------------------------------------------------------------------------------- '【処 理 名】ファイルをコピー '【処理概要】Excelシートに記載したパスにファイルをコピー '【引 数】[I]ByVal targetDir As String コピー元ファイルのあるディレクトリパス '【返 却 値】なし '--------------------------------------------------------------------------------------------------- Public Sub copyFilesByRule(ByVal targetDir As String) Dim sh As Worksheet 'ワークシートオブジェクト Dim arr As Variant '作業領域配列 Dim index As Long 'カウンタ Dim endRowIndex As Long '最終行 Dim fileName As String 'ファイル名 Dim oFso As New FileSystemObject 'ファイルシステムオブジェクト targetDir = AddPathSeparator(targetDir) Set sh = ThisWorkbook.Worksheets("Sheet1") '末尾行 endRowIndex = sh.Cells(Rows.Count, "A").End(xlUp).Row '配列に格納 arr = sh.Range(sh.Cells(2, eCOL.COL_DIRECTORY), sh.Cells(endRowIndex, eCOL.COL_RULE)) 'ファイルをコピー For index = 1 To UBound(arr) fileName = Dir(targetDir & arr(index, eCOL.COL_RULE)) Do While Len(fileName) > 0 oFso.copyFile targetDir & fileName, AddPathSeparator(arr(index, eCOL.COL_DIRECTORY)), True fileName = Dir() Loop Next index Set sh = Nothing Set oFso = Nothing End Sub '--------------------------------------------------------------------------------------------------- '【処 理 名】ディレクトリパスへのセパレータ付与 '【処理概要】ディレクトリパスの末尾にセパレータがなければ付与する '【引 数】[I]ByVal path As String ディレクトリパス '【返 却 値】 なし '--------------------------------------------------------------------------------------------------- Public Function AddPathSeparator(ByVal path As String) As String If Right(path, 1) <> ChrW(92) Then path = path & ChrW(92) End If AddPathSeparator = path End Function参考 あまり知られていないDir関数の特徴moug 参考 Dir 関数msdn
最近のコメント
コメントを残す