カテゴリー: Excell

前回の内容のファイル名を変更して貼り付けの処理の説明を行います。

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

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

処理の説明

メイン処理

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

メイン処理ではB1とB2にパスが指定されているか判定を行い。入力がされていた場合はファイル名変更のメソッドを呼び出します。

ここでのメソッドは自分で作成した関数みたいものです。

ファイル名変更の処理内容

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

上記で行っている処理の内容

受け取ったパス内にファイルが存在する分だけ処理を繰り返す。

ファイルをコピーして出力先のフォルダにファイル名を変更して貼り付け。

受け取ったパス内にフォルダが存在する分だけ処理を繰り返す。

サブフォルダのパスをファイル名変更メソッドに渡す。

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

ファイル名変更()の処理を行っている最中にさらにファイル名変更()を呼び出す処理を再帰処理といいます。要は同じ処理を呼び出しているだけです。

再帰処理のイメージ

ファイルのコピーの内容

    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

フォルダの指定した位置からサブフォルダに含まれるファイルのパスを取得して、フォルダの指定した場所からファイルの間のサブフォルダ名をファイル名に設定しています。

例　

フォルダの指定　C:\Users\nekon\Desktop\仕事\ファイル一覧

ファイルの位置　C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

ファイル名を取得

file = objFile.Name

file = IMG00012.jpg

ファイルのパスを取得

filePath = objFile.Path

filePath = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピーしたいファイルのサブフォルダ名の抜き出し

fileName = Mid(filePath, Len(Range(“B1”)) + 1, Len(filePath) – Len(Range(“B1”)) – Len(file))

fileName = \場所(1)\工事(1)\

\を_に変換

fileName = Replace(fileName, “\”, “_”)

fileName = _場所(1)_工事(1)_

拡張子の取得

kakucho = Mid(file, InStr(file, “.”))

kakucho = .jpg

出力先のパスを設定

syuturyokuPath = Range(“B2”).Value + “\”

syuturyokuPath = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\

施工状況の設定

        Select Case i Mod 3
            Case 1
                seko = "施工前"
            Case 2
                seko = "施工中"
            Case Else
                seko = "施工後"
        End Select

iを3で割った余りで施工前中後を設定している。

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

FileCopy コピー元のファイルパス , コピー先のファイルパス

FileCopy filePath, syuturyokuPath & maisu & fileName & seko & kakucho

コピー元 = C:\Users\nekon\Desktop\仕事\ファイル一覧\場所(1)\工事(1)\IMG00012.jpg

コピー先 = C:\Users\nekon\Desktop\仕事\Excel一覧\出力先\&1&_場所(1)_工事(1)_&施工前&.jpg

maisuはファイルをコピーした数です。

処理全体の内容

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が正常に動くか確認を行うため、テストファイルを作成するのに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上からファイル名のコピーをしてファイル名を変更して貼り付けを行いました。

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

写真の一括貼り付けを行う時に写真の貼り付けたい順番とファイル名を決めます。

名前の付け方にルールを決めてファイル名を取得して、セルに値を設定する様に致しました。

ファイル名から文字列を取得して各項目に設定

ファイル名の決め方

ファイル名　　1_場所_工事_花(1).jpg

表示したい順番、場所、工事種目、施工状況の間に”_“を設定しています。

今回は”_“を判断材料として使用しているだけです。

判断材料はファイルの命名規則に問題なければ何でも大丈夫です。

例 “.””\”等はファイルの命名上問題が発生します。

写真毎に各項目のセルに値を設定

処理の説明

変数の宣言

    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String

検索文字の初期設定

    '検索文字の初期設定
    kensakuMoji = "_"

文字列検索

fileにファイル名が設定されています。

        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")

InStrでファイル名にある”_”の位置を取得しています。

各項目のセルに文字列を設定

        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou

Midで文字列を抜き出しています。

Cellsで抜き出した値をセルに設定しています。

処理全体の内容

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    '写真の一覧を取得
    Dim fileName As Variant
    Dim dblscal As Double
    Dim str As String
    
    Dim day As Date
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim filePath As Variant
    Dim file As Variant
    
'←--------追加
    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String
'---------->
  
    Dim startTime As Double
    Dim endTime As Double
    Dim processTime As Double
    
  
    fileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '画像ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(fileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    
'←------追加
    '検索文字の初期設定
    kensakuMoji = "_"
'---------->
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    'シェルの設定
    Set ObjShell = CreateObject("Shell.Application")
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(fileName) To UBound(fileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            fileName:=fileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left + 1, _
            Top:=ActiveCell.Top + 1, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        Cells(k, j).Select
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
        'ファイルのパスを取得
        filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
        'ファイル名の取得
        file = Mid(fileName(i), Len(filePath) + 1)
        
        '写真のデータを参照
        Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

        '写真の撮影日を取得
        day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
        '写真のデータの参照を解放
        Set ObjFolder = Nothing
        '写真の撮影日をセルに設定
        Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
        
'←------追加
        '文字列検索
        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")
        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou
'-------→
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
    
    'シェルの解放
    Set ObjShell = Nothing
    
    i = i - 1
    k = k - 20
    
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    

    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

今回の内容で各項目に値を設定する事が出来ました。

写真の一括貼り付け処理はエクセル上での操作でファイルを取得すれば自動で各項目に設定するため、自動化完了とします。

また、処理など思いつけば機能の追加を行います。