![]()
筆箱に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
最近のコメント




コメントを残す