はじめに
社内で商品情報をExcelファイルにて管理しています。1つの商品につき1つのエクセルファイルです。
そのファイルなのですが、中には作成日がとても古いものがあり「.xls」拡張子のファイルがちらほら残っているのが気になり、まとめて「.xlsx」に修正することにしました。ついでにファイル命名規則も一貫性がなかったためそちらも併せて修正します。
本記事は、更新したときの内容を纏めます。
準備
Dirコマンド等を使って、リネームリストを下記のように作成し、それをもとにリネームしていきます。新しいファイル名はD列をE列にコピり、Excelの置換機能で「.xls ⇒ .xlsx」としました。そのたファイル名の微修正を行った際も置換機能は便利です。
- リネームリスト.xlsm
- B列にフォルダ名
- D列に現在のファイル名
- E列に新しいファイル名
- H列はマクロによってリネーム後にチェックを入れていき、後で成否を確認するための列とします。
処理
- 処理
- 現在のファイル名と新しいファイル名に違いがあったらリネーム対象とします。
- リネーム対象のファイルは、開いた後、新しいファイル名で保存します。この時、xlOpenXMLWorkbookオプションで.xlsx形式にします。
- リネーム後の古いファイル名のファイルは削除せずに、Doneというフォルダを作りそこに退避させました。
マクロ
リネームリスト.xlsmに下記のマクロを記述します。
複数のExcelファイルを扱う際にやっといた方がいいことはコチラの記事でも少し書きました。
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