コピペで使えるVBAのコード置き場

ファイル名が条件に合うものをコピーする

筆箱に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

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です