指定したフォルダにあるファイルをコピーしてファイル名を変更して貼り付け

前回の写真の一括貼り付け処理の内容でファイル名から文字列を取得して各項目に設定する方法を行いました。

そこでVBAが正常に動くか確認を行うため、テストファイルを作成するのに50枚の写真のファイル名を変更致しました。

50枚のファイル名を変更するのに15分ぐらいの時間と簡単な文字の入力を行ったのですが拷問の様な作業に感じたのでフォルダ名を参照しファイル名を自動で変更するマクロを組みました。

ファイル名の変更処理を行っている内容

指定したフォルダの下にある全てのフォルダのファイルからファイルをコピーして、出力先のフォルダにファイル名を変更して貼り付けを行います。

ファイル名の変更内容のルールとしてファイルの数とファルダ名を取得してファイル名に設定しています。

ファイル名のルール　番号_フォルダ名(場所)_フォルダ名(工事)_施工前中後

Excelファイル

フォルダの指定とファイルを貼り付ける位置を設定しています。

フォルダの指定

青枠で囲ってあるフォルダ内の全てのファイルをコピーします。

工事フォルダ全てに3つのファイルを置いてあります。

出力先フォルダ

処理の実行

ファイル名を変更して貼り付け

ファイル一覧フォルダの下にある全てのファイルをコピーして貼り付けています。

ファイル名取得処理の内容

Sub サブフォルダ含むファイル名取得()

    Dim maisu As Integer
    Dim strFolderpass As String
    
    '枚数の初期設定をします。
    maisu = 1
    
    '対象フォルダのパスを設定
    strFolderpass = Range("B1").Value
    
    'ファイルのパスの判定
    If strFolderpass = "" Or Range("B2").Value = "" Then
        MsgBox "対象フォルダのパスがありません。パスを入力してください。"
    Else
        'ファイル名変更のメソッドを呼び出します。
        Call ファイル名変更(strFolderpass, maisu)
    End If

End Sub




Sub ファイル名変更(strFolderpass As String, maisu As Integer)

    Dim objfFSO As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim objSubFolders As Object
    Dim objSubFolder As Object
    Dim fileName, file, filePath As String
    Dim kakucho, seko As String
    Dim i As Integer
    Dim syuturyokuPath As String
    
    
    'ファイルやフォルダを操作するオブジェクトの生成
    Set objfFSO = CreateObject("Scripting.FileSystemObject")

    '対象フォルダのファイルオブジェクトをセット
    Set objFiles = objfFSO.GetFolder(strFolderpass).Files
    
    i = 1
    'ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け
    For Each objFile In objFiles
        file = objFile.Name
        filePath = objFile.Path
        fileName = Mid(filePath, Len(Range("B1")) + 1, Len(filePath) - Len(Range("B1")) - Len(file))
        fileName = Replace(fileName, "\", "_")
        kakucho = Mid(file, InStr(file, "."))
        syuturyokuPath = Range("B2").Value + "\"
        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select
        FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho
        
        maisu = maisu + 1
        i = i + 1
    Next objFile
    

    '対象フォルダのサブフォルダファイルオブジェクトをセット
    Set objSubFolders = objfFSO.GetFolder(strFolderpass).SubFolders

    'サブフォルダを含むファイル名取得
    For Each objSubFolder In objSubFolders
     
        If objSubFolder.Name <> "" Then
            
            'サブフォルダのパスをメソッドへ渡して再帰的に処理を行う
            Call ファイル名変更(objSubFolder.Path, maisu)
            
        End If
         
    Next objSubFolder

    '使用したオブジェクトの解放
    Set objfFSO = Nothing
    Set objFiles = Nothing
    Set objFile = Nothing
    Set objSubFolders = Nothing
    Set objSubFolder = Nothing

End Sub

今回はVBA上からファイル名のコピーをしてファイル名を変更して貼り付けを行いました。

次回は処理の説明を行います。