はじめに

社内で商品情報をExcelファイルにて管理しています。１つの商品につき１つのエクセルファイルです。
そのファイルなのですが、中には作成日がとても古いものがあり「.xls」拡張子のファイルがちらほら残っているのが気になり、まとめて「.xlsx」に修正することにしました。ついでにファイル命名規則も一貫性がなかったためそちらも併せて修正します。

本記事は、更新したときの内容を纏めます。

準備

Dirコマンド等を使って、リネームリストを下記のように作成し、それをもとにリネームしていきます。新しいファイル名はD列をE列にコピり、Excelの置換機能で「.xls ⇒ .xlsx」としました。そのたファイル名の微修正を行った際も置換機能は便利です。

リネームリスト.xlsm
- B列にフォルダ名
- D列に現在のファイル名
- E列に新しいファイル名
- H列はマクロによってリネーム後にチェックを入れていき、後で成否を確認するための列とします。

処理

処理
- 現在のファイル名と新しいファイル名に違いがあったらリネーム対象とします。
- リネーム対象のファイルは、開いた後、新しいファイル名で保存します。この時、xlOpenXMLWorkbookオプションで.xlsx形式にします。
- リネーム後の古いファイル名のファイルは削除せずに、Doneというフォルダを作りそこに退避させました。

マクロ

リネームリスト.xlsmに下記のマクロを記述します。
複数のExcelファイルを扱う際にやっといた方がいいことはコチラの記事でも少し書きました。

リネームリスト.xlsm

Sub rename_book()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)

    Dim FolderName As String '現在のフォルダ
    Dim DoneFolderName As String 'リネーム澄みファイルを退避させるフォルダ
    Dim CurrentName As String '現在のファイル名
    Dim NewName As String '新しいファイル名
    Dim CurrFullName As String 'ファイルパスを含めた現在のフルネーム
    DoneFolderName = "D:\Done"
    Dim CurFile As Workbook
    Dim Col_folder, Col_Curr, Col_New, Col_Chk As Long
    Dim Endrow As Long
    Dim i As Long
    Dim TimeStr As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    With ws
        'フォルダー名_列番号
        Col_folder = .Columns("B").Column
        '現在のファイル名_列番号
        Col_Curr = .Columns("D").Column
        '新ファイル名_列番号
        Col_New = .Columns("E").Column
        'チェック列_列番号
        Col_Chk = .Columns("H").Column
        .Columns(Col_Chk).Clear
        
        'リネームリストの最終行を取得する。
        Endrow = .Cells(Cells.Rows.Count, Col_New).End(xlUp).Row
        Dim i2 As Long
        i2 = 1
                
        'リネームリストを2行目から見ていく。
        For i = 2 To Endrow
            FolderName = .Cells(i, Col_folder).Value
            CurrentName = .Cells(i, Col_Curr).Value
            NewName = .Cells(i, Col_New).Value
            CurrFullName = FolderName & "\" & CurrentName
            
            '現在のファイル名と新規ファイル名の値が違ったらファイルの存在を確認して開く。
            If (CurrentName <> NewName) And (Dir(CurrFullName) <> "") Then
                Set CurFile = _
                Workbooks.Open(Filename:=CurrFullName, UpdateLinks:=0)
                With CurFile
                
                    '.xlsx形式で保存する。
                    .SaveAs _
                     Filename:=FolderName & "\" & NewName, _
                     FileFormat:=xlOpenXMLWorkbook
                     .Close
                    
                    '保存が済んだらチェック列に"Done"と記入
                    ws.Cells(i, Col_Chk).Value = "Done"
                       
                    On Error Resume Next
                    
                    TimeStr = _
                    Format(Date, "yymmdd") & "_" & Format(Time, "hhmmss")
                    
                    Name CurrFullName As _
                    DoneFolderName & "\" & TimeStr & CurrentName
                    
                    '無効なファイル名だったら無視する。
                    If Err.Number = 52 Then
                        Err.Clear
                    End If
                    
                    On Error GoTo 0
                    
                End With
            End If
        Next
    End With
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

はまったこと。環境依存文字を使ったファイル名

環境依存文字が含まれるファイル名のファイルに関して。ファイルは開けるが、保存の際に環境依存文字が「？」に文字化けしてエラー（保存ができなかった。）新しいファイル名列で環境依存文字を消したファイル名に修正して対応するようにしたが、古いファイルを退避フォルダに移動する際にまたエラーになる。しかたなくon error resume nextでエラー無視して、
環境依存文字が含まれたリネーム後の不要ファイルは別途まとめて移動した。

環境依存文字が含まれるファイル名か否かのチェックにはどっかの質問サイトで拾った下記のコードをお借りした。ソースを忘れてしまったので載せることができないけれど、とても助かりました。ありがとうございます。

アクティブシート内の環境依存文字が含まれるセルを色付けする。

Function CheckUNICODE(ByVal txt As String)
    Dim i As Integer
    Dim c As String
       For i = 1 To Len(txt)
            c = Mid$(txt, i, 1)
            If Asc(c) = 63 Then
               If "?" <> txt Then
               CheckUNICODE = 1 'Unicode
               Exit Function
               End If
            ElseIf AscW(c) > -8193 And AscW(c) < -5887 Then
               CheckUNICODE = 2 '外字
            Else
               CheckUNICODE = 0 '一般(JIS)
            End If
       Next
End Function

Sub Macro_8996251()
    Dim Rng As Range
    Dim c As Variant
    On Error Resume Next
    Set Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 23)
    If Err() <> 0 Then Exit Sub
    On Error GoTo 0
    For Each c In Rng.Cells
      If CheckUNICODE(c.Value) = 1 Then
         c.Interior.ColorIndex = 3
      End If
    Next c
End Sub