VBA勉強会課題
先日バズっていた正気の沙汰とは思えないフォルダの作り方をする他課の課長。
というツイートに対するマクロを作成。
バラバラになっているフォーマットを統一できればOKです。
動作イメージと処理の流れ
- 親フォルダを選択する
- FileSystemObjctを使用し、子フォルダのフォルダをループ処理。
- 処理前のファイル名を転記
- 全角＆半角数字以外を空白に置換
- 先頭から6文字文切り出す
- 桁が合わない箇所の月を0埋めする
- フォルダ名を変更
コード
Option Explicit
'「Microsoft VBScript Regular Expressions 5.5」にチェックを付けること
Sub ChangeDirName()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("フォルダ名リネーム")
'FileSystemObjectを宣言
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DirObj As Object
'フォルダ選択ダイアログ
Dim rslt As VbMsgBoxResult
Dim fd As FileDialog
Dim FolderPath As String
Dim DirName As String
'ダイアログで選択したフォルダを取得
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセルor選択の振り分け
If (fd.Show = True) Then
FolderPath = fd.SelectedItems.Item(1)
Else
MsgBox "キャンセルしました"
End
End If
Dim i As Long: i = 0
'getFolderメソッドでsubfoldersを指定し、すべてのフォルダ名を取得する
For Each DirObj In FSO.getfolder(FolderPath).subfolders
DirName = DirObj.Name
ws.Cells(4 + i, 1) = DirName
'正規表現にて数字のみを切り出し
DirName = FindNumberRegExp(DirName)
'転記
ws.Cells(4 + i, 2) = DirName
'先頭から６文字取得
ws.Cells(4 + i, 3) = Left(DirName, 6)
'6桁じゃなかったら月を0埋め
If Len(Cells(4 + i, 3)) <> 6 Then
ws.Cells(4 + i, 4) = Left(Cells(4 + i, 3), 4) & "0" & Mid(Cells(4 + i, 3), 4 + 1)
Else
ws.Cells(4 + i, 4) = Cells(4 + i, 3)
End If
'フォルダ名の変更
DirObj.Name = Cells(4 + i, 4).Value
i = i + 1
Next
End Sub
Function FindNumberRegExp(s)
'// 正規表現クラスオブジェクト
Dim reg As New RegExp
'// 検索条件＝数字以外を抽出
reg.Pattern = "[^0-9０-９]"
'// 文字列の最後まで検索する
reg.Global = True
'// 数字以外の文字を空文字に置き換える
FindNumberRegExp = reg.Replace(s, "")
End Function
解説
まず、'「Microsoft VBScript Regular Expressions 5.5」にチェックを付けます。
VBEのツール→参照設定→Microsoft VBScript Regular Expressions 5.5
Function FindNumberRegExp(s)で正規表現クラスオブジェクトを利用するのに必要。
ダイアログ取得
'FileSystemObjectを宣言
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DirObj As Object
'フォルダ選択ダイアログ
Dim rslt As VbMsgBoxResult
Dim fd As FileDialog
Dim FolderPath As String
Dim DirName As String
'ダイアログで選択したフォルダを取得
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセルor選択の振り分け
If (fd.Show = True) Then
FolderPath = fd.SelectedItems.Item(1)
Else
MsgBox "キャンセルしました"
End
End If
ダイアログで選択したフォルダの中のフォルダをループ処理します。
ループ処理内容
For Each DirObj In FSO.getfolder(FolderPath).subfolders
DirName = DirObj.Name
ws.Cells(4 + i, 1) = DirName
'正規表現にて数字のみを切り出し
DirName = FindNumberRegExp(DirName)
'転記
ws.Cells(4 + i, 2) = DirName
'先頭から６文字取得
ws.Cells(4 + i, 3) = Left(DirName, 6)
'6桁じゃなかったら月を0埋め
If Len(Cells(4 + i, 3)) <> 6 Then
Cells(4 + i, 4) = Left(Cells(4 + i, 3), 4) & "0" & Mid(Cells(4 + i, 3), 4 + 1)
Else
Cells(4 + i, 4) = Cells(4 + i, 3)
End If
'フォルダ名の変更
DirObj.Name = Cells(4 + i, 4).Value
i = i + 1
Next
Functionはよさそうなものを拾って使わせていただきました！
少しいじっていますがほぼほぼそのままです。
Function FindNumberRegExp(s)
'// 正規表現クラスオブジェクト
Dim reg As New RegExp
'// 検索条件＝数字以外を抽出
reg.Pattern = "[^0-9０-９]"
'// 文字列の最後まで検索する
reg.Global = True
'// 数字以外の文字を空文字に置き換える
FindNumberRegExp = reg.Replace(s, "")
End Function
詳しくはリンク先参照。
関数に文字列を渡すと、全角＆半角の数字以外を空白で置換して返してくれます。
その後、統一感のあるフォーマットにそろえるために段階を踏んで整形しています。
どのようにしてリネームしているかが追えるようにセルに転記しているので、万が一この処理でうまく動作しなかった場合は処理後に手で修正ができるようどのフォルダがどのようにリネームされているか追えるようにしています。
（おそらくすべてのパターンに対応させるのは無理なのであきらめも重要！）
詳細一覧だと見切れるのでアイコンでBeforAfter
リネーム開始！
実行シートの様子
フォルダの一覧
きれいに西暦順で並んでいるので完了です！
終わり
フォルダ名がバラバラだと探すのも大変ですよね。。。
今回、ツール作成に１時間ぐらいかかったので、手作業のが早いと思います(笑)
もっと数があったら費用対効果でそう！
今回の課題は業務改善ぽくて会社でも利用シーンがあったら作ってみたいと思いました。