【Excelマクロ】目的のファイルを指定フォルダにコピー＆ペーストする

実現したいこと

• 目的のファイルを格納するサブフォルダを検索する。
  
• 目的のファイルを指定フォルダへコピーする。
  
• コピーするファイルはファイル名を特定の形式に変更する。
  

工程分解

1. 親フォルダのフルパス、コピー先フォルダのフルパス、サブフォルダの検索条件を指定する。
   
2. 親フォルダからサブフォルダと目的のファイルを検索する。
   
3. ファイル名を変更する。
   
4. 指定フォルダに目的のファイルをコピー＆ペーストする。
   

ソースコード

Sub CopyAndRenameFile()

    '変数の宣言
    Dim ParentFolderPath, FolderPathFrom, FolderPathTo
    Dim FileName1, FileName2
    Dim Arr1() As String, Arr2() As String
    Dim FilePathFrom, FilePathTo
    Dim FSO, SFs, SF, SFName, TFN
    
    '親フォルダのフルパスを取得
    ParentFolderPath = Range("A2")
    
    'FileSystemObjectのインスタンス化
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '指定したフォルダに存在する全てのサブフォルダを取得
    Set SFs = FSO.GetFolder(ParentFolderPath).SubFolders
    
    'サブフォルダから目的ファイルを格納しているフォルダを検索
    For Each SF In SFs
        'サブフォルダ名を取得
        SFName = SF.Name
        '検索情報を取得
        TFN = Range("B2")
        
        '検索情報を含むサブフォルダの場合、フルパスを生成
        If InStr(SFName, TFN) <> 0 Then
            FolderPathFrom = ParentFolderPath & "\" & SFName
            Exit For
        End If
    Next
    
    '該当したサブフォルダ内で指定した拡張子に合致するファイル名を取得
    FileName1 = Dir(FolderPathFrom & "\*.txt")
    '該当したファイルのフルパスを生成
    FilePathFrom = FolderPathFrom & "\" & FileName1
    
    'ファイル名の変更
    '変更前：A(B)C　→　変更後：A_C
    Arr1 = Split(FileName1, "(")
    Arr2 = Split(Arr1(1), ")")
    FileName2 = Arr1(0) & "_" & Arr2(1)
    
    'コピー先フォルダのフルパスを取得
    FolderPathTo = Range("C2")
    '変更したファイル名にて、コピー後のファイルのフルパスを生成
    FilePathTo = FolderPathTo & "\" & FileName2
    
    'コピー＆ペーストの実行
    FileCopy FilePathFrom, FilePathTo
    
End Sub