このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

Excel VBAでファイル名を一括変更する【実務で活用できる】

スポンサーリンク

ファイル名を変更したい場合はどんな時でしょうか?
例えば、以前紹介したOutlookメイルの添付ファイルを一括ダウンロードして保存していたりした場合などがそうだと思います
さて、そのファイル名を変更しようと思った時に、ファイル内容を確認しないとファイル名がつけられない場合があります。配布したデータのファイル名やシート名を改変されている場合や同一ファイル名で配布してしまった場合等々様々な状況が考えられます

こんな場合はどうすれば効率よく作業できるでしょうか
手動でひとつづつ開いて確認してから変更していたら、気が遠くなる作業です

そんな時の解決策は、やはりVBAに頼るしかないでしょう。では、そのやり方を検討していきます

ファイル名を一括で変更する方法について2つのパターンを紹介します

スポンサーリンク

ファイル名一括変更のロジックと設定シート

ロジックをフローチャートで確認

・このフローは設定に従い当該ファイルのセルから読み込んだデータでファイル名を一括変更します
・事前に右上に記載している「ファイル名不定準備」をシートに設定してから実行します

①ファイル名一括変更設定用シート

・「A列」「B列」に基本データを設定しておきます。この例では「名称」と「ID]です
・「H10」に付け替えるファイル名を入力します(設定を複数保存し番号で指定できます)
・「L10」に検索するシート名を入力します
・「O10」にシート内セル番地を入力します(A列に設定した名称が記載されているセル)
・「i7」は、開くファイルにパスワード設定されている場合に入力しておきます
・「i8」で設定を使用する番号を指定します(例:1=10行目、2=11行目)
「L17」以下は変更できなかったファイル名を列挙するようにしています

②ファイル名一括変更用(簡易版)シート

・このシートは簡易版のファイル名変更ツールです
・「フォルダ参照」ボタンで対象ファイルの保存フォルダを指定します
・フォルダを指定すると、「B1」にフォルダパス「A3」以下にファイル名を列挙します
・「B3」セル以下に変更するファイル名を記載します
・準備が整ったら「ファイル名変更スタート」ボタンで実行します
「C列」の判定には、ファイル名変更の「成功」「失敗」を記録します

ファイル名を一括変更するコード

・それでは、VBAコードを紹介します

①ファイル名一括変更設定用シート用のコード

Option Explicit
Private Declare Function GetInputState Lib "USER32" () As Long  'DoEventsの代わり
'ファイル名変更(複数ファイルの選択可能で処理する)
Sub Open_File_NameEdit()
    Dim OpenFileName As Variant
    Dim PathName As String, fileName As String, pos As Long
    Dim kakuchosi As String '拡張子用
    Dim buf As String, buf2 As String
    Dim selectFName As Variant
    Dim xls As New Excel.Application
    Dim wb As Workbook, sh As Worksheet
    Dim ShName As String, pw As String
    Dim fnset As Long, intRow As Long, intCol As Long
    Dim i As Long, strMsg As String
    Dim strNewFileName As String
    
    On Error GoTo ErrHandler
    
    fnset = Range("I8")     'ファイル名指定フラグ
    pw = Range("I7")        'パスワード
    '不正ファイルリスト用スペースを初期化
    Range(Cells(17, 12), Cells(17, 12).End(xlDown)) = ""
    '対象ワークシート名等の設定を変数に入力
    fnset = fnset + 9
    ShName = Cells(fnset, 12) 'Range("L10")
    If ShName = "" Then
        MsgBox "ファイル名等の設定がありません!中止します!"
        Exit Sub
    End If
    intRow = Cells(fnset, 17)
    intCol = Cells(fnset, 18)
    strNewFileName = Cells(fnset, 8) 'Range("H10")
    'ファイル選択ダイアログを表示
    selectFName = Application.GetOpenFilename( _
            FileFilter:="Microsoft Excel,*.xls?, 全てのファイル, *.*", _
            FilterIndex:=1, _
            Title:="ファイルを選択してください(複数可)", _
            MultiSelect:=True)
    
    Call マクロ開始 '動作制御用
    '選択されたファイルに対する処理
    If IsArray(selectFName) Then
        '全てのファイルに繰り返し処理を行う
        For Each OpenFileName In selectFName
            pos = InStrRev(OpenFileName, "\")
            PathName = Left(OpenFileName, pos)      'パス部分
            fileName = Mid(OpenFileName, pos + 1)   'ファイル名
            pos = InStrRev(fileName, ".")
            kakuchosi = Mid(fileName, pos)          '拡張子
            'ファイルをリードオンリーで開き確認する
            Set wb = xls.Workbooks.Open(fileName:=PathName & fileName, _
                    Password:=pw, UpdateLinks:=0, ReadOnly:=True) ', _
                    CorruptLoad:=xlExtractData) '抽出モードで開く場合
            If GetInputState() Then DoEvents 'DoEventsを入れておく
            'シート内のセルからデータを取得する処理はここから
            On Error Resume Next
            Set sh = wb.Worksheets(ShName)
            If sh Is Nothing Then
                'シートが見つからない場合ファイル名を書き出す
                Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                    "シート名変更:" & fileName
                strMsg = "が変更されている"
                GoTo tugi
            Else
                buf2 = sh.Cells(intRow, intCol)
                If buf2 = "" Then
                    'セルにデータがない場合ファイル名を書き出す
                    Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                        "セルデータ不明:" & fileName
                    strMsg = "の内容が変更されている"
                    GoTo tugi
                Else
                    '置き換えが必要な場合設定とりあえずスペース削除
                    buf2 = Replace(Replace(buf2, " ", ""), " ", "")
                    'VLookupで設定取得
                    buf = Application.WorksheetFunction.VLookup(buf2, _
                                        Range("A:B"), 2, False)
                    If buf = "" Then
                        '設定を取得できない場合ファイル名を書き出す
                        Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                            "セルデータ不明:" & fileName
                        strMsg = "の内容が変更されている"
                        GoTo tugi
                    Else
                        On Error GoTo ErrHandler
                        wb.Close savechanges:=False 'ファイルを閉じる
                        Set xls = Nothing
                        Set wb = Nothing
                        Set sh = Nothing
                        '閉じたファイル名を変更
                        fileName = buf & "【" & buf2 & "】" & _
                                            strNewFileName & kakuchosi
                        Name OpenFileName As PathName & fileName
                    End If
                End If
            End If
            GoTo nextloop
tugi:
            MsgBox fileName & "はシート名「" & ShName & "」" & _
                    strMsg & "と思われるので処理できません!" & _
                    "正しく修正してから再度実行してください!"
            On Error GoTo ErrHandler
            wb.Close savechanges:=False 'ファイルを閉じる
            Set xls = Nothing
            Set wb = Nothing
            Set sh = Nothing
nextloop:
        Next
    Else
        Call マクロ終了
        MsgBox ("ファイルを選択しないで終了")
        Exit Sub
    End If
    Call マクロ終了
    MsgBox "選択したファイル名の変更が終了しました", _
                    vbOKOnly + vbInformation, "ファイル名一括変更"
    Exit Sub

ErrHandler:
    MsgBox "「" & fileName & "」の処理中にエラーが発生しました" & _
            vbCrLf & Err.Description, vbExclamation, "ファイル名一括変更"
    Set xls = Nothing
    Set wb = Nothing
    Set sh = Nothing
    Call マクロ終了
End Sub

・19~32行目で、シートの設定を読み込んでいます
・34行目で、ファイル選択ダイアログを呼び出しています(複数選択可)
・40行目「Call マクロ開始」と110行目「Call マクロ終了」のコードは省略しています
・60行目等で「シート名変更」や「セルデータ不明」の場合、変更できなかった
 ファイル名とその理由をシートに書き出す処理を記載しています
・93行目「Name OpenFileName As PathName & fileName」がファイル名変更コード

②ファイル名一括変更用(簡易版)シート用のコード

'ファイル名一括変更【簡易版】
Sub Do_File_NameChange()
    Dim OpenFileName As String
    Dim PathName As String
    Dim i As Long, lnRow As Long
    Dim strNewFileName As String

    lnRow = Cells(1, 1).End(xlDown).Row
    If lnRow < 3 Then MsgBox "ファイルがセットされていません!中止します!": Exit Sub
    If Cells(1, 2).Value <> "" Then
        PathName = Cells(1, 2).Value & "\"
    Else: MsgBox "ファイルパスが不明です!中止します!": Exit Sub
    End If
    For i = 3 To lnRow
        OpenFileName = PathName & Cells(i, 1).Value
        strNewFileName = PathName & Cells(i, 2).Value
        If Dir(strNewFileName) <> "" Then
            MsgBox strNewFileName & "はすでに存在します"
            Cells(i, 3).Value = "失敗"
        Else
            Name OpenFileName As strNewFileName
            Cells(i, 3).Value = "成功"
        End If
    Next
    MsgBox "設定したファイル名の変更が終了しました", _
                vbOKOnly + vbInformation, "ファイル名一括変更"
End Sub
Sub selectionFolder()
    Dim strWORK As String
    strWORK = getFOLDER()  'フォルダーの選択関数を呼ぶ
    Range("B1").Formula = strWORK
End Sub

'フォルダー選択ダイアログを表示
Function getFOLDER() As String
    Dim dlg As FileDialog

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時
    If dlg.Show = False Then
        getFOLDER = ""
        Exit Function
    End If
    ' フォルダーのフルパスを変数に格納
    getFOLDER = dlg.SelectedItems(1)
    Set dlg = Nothing
End Function

'フォルダ内のファイル名を取出して、セルに反映する
Sub GetFileNameSet()
    Dim strFolder   As String  'フォルダー名
    Dim strFileName As String  'ファイル名
    Dim nYLine      As Integer '行カウンタ
    Dim strFileType As String
    
    strFileType = Range("G4")  'ファイル形式
    Call selectionFolder
    strFolder = Range("B1") & "\"  '検索するフォルダー
    strFileName = Dir(strFolder & strFileType) '最初のファイル名
    'ファイルが見つからなくなるまでループしてデータをセットする
    nYLine = 3  '3行目からセット
    'セルデータ初期化
    Range(Cells(nYLine, 1), Cells(nYLine, 3).End(xlDown)) = ""
    Do While strFileName <> ""   ' ループを開始します。
        'セルにファイル名をセットする
        If strFileName <> "" Then
            Cells(nYLine, 1) = strFileName 'セルにファイル名をセット
            nYLine = nYLine + 1      'カウントアップ
        End If
        strFileName = Dir   '次のファイル名を返す
    Loop

End Sub

【簡易版の説明】
・「フォルダ参照」ボタンで「GetFileNameSet」プロシージャを起動して
 フォルダ内ファイルをシートに書き出す処理を実行しています
・「ファイル名変更スタート」ボタンで「Do_File_NameChange」を実行しています
21行目の「Name OpenFileName As strNewFileName」がファイル名変更コード
・その前後で「成功」か「失敗」かをシートに書く出す処理をしています

まとめ(おわりに)

まとめと感想など

・93行目ファイル名変更コード「Name OpenFileName As PathName & fileName」の
 「PathName」部分を別のパス名に変更すれば、元のファイルはそのままで別の
 フォルダに名前を変更したファイルを保存することが出来ます

・各部署に配布したファイルで報告を受け取るようにしている場合、ファイルの改変は絶対にしないように周知していても、平気で改変されてきちゃうんですよね(-_-;)
・「ファイル名の改変」はもちろん、「シート名の変更」や「シート内の列や行の追加や削除」など様々なケースがあり、本当に嫌になります
・そんな時にこのツールを使えば、改変があるかどうかの確認もできますし非常に便利だと思います。こんな状況に置かれている方は是非一度使ってみてください(^^)/

今後の記事について

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです(^^;
是非!サンプルがありますので使ってみてください(^^)/


【今後の記事内容はどうしようかなぁ・・・】
・今までに紹介した記事で使用したコードの改変も検討します
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタいろいろ」などなど・・・・・
・今後これらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください