VBAツール：ファイル名の特定の場所に半角数字がある場合にリネームするツール
１．ツールの内容
ファイル名の半角括弧「( )」で囲まれた値が半角数字の場合、その半角数字にファイル名がリネームされます。
やること
このような感じで対象のファイルだけがリネームされます。
２．ツールのトップ画面
Excelの見た目はこんな感じです。
・使い方
(1)「対象フォルダ」を指定する。
(2)「実行」ボタンを押す。
(3)指定した「対象フォルダ」のファイルがリネームされます。
・シート名
メイン画面のみです
(1)メイン画面：ユーザが操作する画面です。
３．サンプルコード
VBAをコピペして、「実行」ボタンで「実行Main」を呼び出せばツールは動きます。
※「RegExpクラス」を利用しているので、「ツール」→「参照設定」→「Microsoft VBScript Regular Expressions 5.5」にチェックをいれてから実行してください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
Option Explicit '************************************' 'Main' '************************************' Sub 実行Main() Dim FolderPath As String If MsgBox("実行しますか？", vbYesNo) = vbYes Then '各パスの取得' FolderPath = Worksheets("メイン画面").Range("C4") Call リネーム(FolderPath) MsgBox "完了しました。" Else MsgBox "実行をキャンセルしました。" End If End Sub '************************************' 'フォルダーの指定' '************************************' Sub フォルダーの指定() Dim xF As FileDialog Dim SelectFolder As String Set xF = Application.FileDialog(msoFileDialogFolderPicker) With xF '//最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。' .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") '//ダイアログの左上に出てくるタイトル名' .Title = "フォルダの指定" .AllowMultiSelect = False If .Show = True Then 'ダイアログを開く' SelectFolder = .SelectedItems(1) '指定したフォルダを返す' End If End With If SelectFolder <> "False" Then Range("C4") = SelectFolder End If Set xF = Nothing End Sub '************************************' 'ファイルをリネームする' '************************************' Function リネーム(FolderPath As String) Dim buf As String Dim NewFileName As String Dim FPath As String Dim cnt As Long Dim FSO As Object Dim chk_Name_Left As String Dim chkLen_Name_Left As Long Dim chk_FName As String Dim FExtension As String Dim chkLen_FExtension As Long Set FSO = CreateObject("Scripting.FileSystemObject") buf = Dir(FolderPath & "\(*)*") Do While buf <> "" cnt = cnt + 1 'ファイルを含めたフルパス' FPath = FolderPath & "\" & buf '検索対象文字が前から何番目か取得'" chkLen_Name_Left = InStr(buf, ")") chk_Name_Left = Left(buf, 1) 'チェック対象の文字列を取得' chk_FName = Right(Left(buf, chkLen_Name_Left - 1), chkLen_Name_Left - 2) 'ファイルの拡張子位置を取得' chkLen_FExtension = InStrRev(buf, ".") 'パスから拡張子を取得' FExtension = Right(buf, Len(buf) - chkLen_FExtension + 1) 'リネームの対象ならファイルをリネームする。' If chk_Name_Left = "(" Then '対象文字列が半角数値かどうかチェック' If IsNumericRegExp(chk_FName) = True Then NewFileName = chk_FName & FExtension FSO.GetFile(FPath).Name = NewFileName End If End If buf = Dir() Loop Set FSO = Nothing End Function '************************************' '//RegExpを使って対象文字列が半角数値かどうかチェックする。' '//「RegExpオブジェクト」の利用方法' '//「ツール」→「参照設定」→「Microsoft VBScript Regular Expressions 5.5」にチェックをいれる' '************************************' Function IsNumericRegExp(chk_FName As String) As Boolean Dim chk_reg As New RegExp '//検索条件' '//半角数値の形式のみ' chk_reg.Pattern = "^[0-9]+$" '//最後までチェックする' chk_reg.Global = True '//半角数値のみならTrueを返す' If chk_reg.Test(chk_FName) = False Then IsNumericRegExp = False Else IsNumericRegExp = True End If End Function |
関連記事
