スキルアップ・問題解決なら、モーグにおまかせ！

フォルダー名の変名のコードを作成しました。
（括弧内にある西暦部分をを先頭に配置する）
 
西暦部抜き出し関数(ExtractNumber)は以前ネットで見つけたコードの使いまわしです。
 
とりあえず、エラーは出ませんが
　利用回数が少ないので検証不足で問題があるか良くわかりません。
 
何か？気づかれた点などアドバイス有ればお願いします。
 
 
 
Option Explicit
 
Sub RenameFolders()
      Dim fso As Object
      Dim folderPath As String
      Dim folder As Object
      Dim newName As String
      Dim currentName As String
      Dim num As String
      Dim delNum As String
     
      'ダイアログを表示してターゲット・フォルダーを指定
      With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a Folder"
            .AllowMultiSelect = False
            If .Show = -1 Then
                  folderPath = .SelectedItems(1)
                  folderPath = folderPath & "\"
            End If
      End With
     
      ' Create a FileSystemObject
      Set fso = CreateObject("Scripting.FileSystemObject")
     
      ' ターゲット・フォルダー内のフォルダーを処理
      For Each folder In fso.GetFolder(folderPath).SubFolders
            ' 変名前のフォルダー名
            currentName = folder.Name
         
            ' 末尾の西暦部分を取り出す
            num = ExtractNumber(currentName)
         
            '削除すべき西暦部（含む括弧）
            delNum = "(" & num & ")"
         
            'フォルダー名候補（変名前のフォルダー名から西暦部分を削除）
            newName = Replace(currentName, delNum, "")
         
            ' 変名後のフィルダー名（西暦 & フォルダー名候補）
            newName = num & " " & newName
         
            ' 変名
            folder.Name = newName
      Next folder
     
      ' Close処理
      Set fso = Nothing
End Sub
 
Function ExtractNumber(str As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\(([0-9]{4})\)"
    If regex.Test(str) Then
        ExtractNumber = regex.Execute(str)(0).SubMatches(0)
    Else
        ExtractNumber = ""
    End If
End Function

動作しているのですから基本的にOKだと思います。
 
あえて申し上げるとすると
ExtractNumberの中で、呼ばれる都度、正規表現objectを作るのは無駄のような気がします。
（モジュールベースの変数を使って、一度だけ作成することでよいと思います。
  尤も、ロスと言っても、数個程度であれば気にすることはないかとも思います。
  多数を相手にする場合は検討してみてください。)
 
以下は、こう書いたほうが良いということではなく、こういう書き方もあるという参考です。
 

Sub RenameFolders()
    Dim fso   As Object
    Dim folderPath As String
    Dim folder As Object
    Dim regex As Object

    'フォルダの指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            folderPath = folderPath & "\"
        End If
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    '正規表現の設定
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(.*?)[(（]([0-9]{4})[)）](.*?)"

    'サブフォルダのRename
    For Each folder In fso.GetFolder(folderPath).SubFolders
        If regex.test(folder.Name) Then
            folder.Name = regex.Replace(folder.Name, "$2 $1$3")
        End If
    Next folder
End Sub

Sub test()
    Dim regex As Object
    Dim s1$, s2$, s3$
        
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(.*?)[(（](\d{4})[)）](.*?)" '全角カッコもあるものとしました
    
    s1 = "aaa(2023)"
    s2 = "aaa(2023)bbb"
    s3 = "(2023）aaa"
    
    Debug.Assert regex.Replace(s1, "$2 $1$3") = "2023 aaa"
    Debug.Assert regex.Replace(s2, "$2 $1$3") = "2023 aaabbb"
    Debug.Assert regex.Replace(s3, "$2 $1$3") = "2023 aaa"
    MsgBox "OK"
End Sub

アドバイスありがとうございます。
 
サブルーチンないで毎回、同じ定義を呼び出すのは確かに無駄ですね。
メインのSUBで '正規表現の設定　を宣言するように変更して
ついでにサブルーチンも使用しないようにしました。
 
全角括弧は想定外だったので全角の括弧が合った場合は半角に変更する
処理を追加しました。
（この部分もネットから探したのコードをそのまま利用しています）
 
simpleさんの「サブフォルダのRename」にある
folder.Name = regex.Replace(folder.Name, "$2 $1$3")が理解できていないので
旧コードの使いまわしになっています。
 
regex.Pattern = "(.*?)[(（]([0-9]{4})[)）](.*?)"　は括弧以外の文字列　？
 
Option Explicit
Sub RenameFolders()
      Dim fso As Object
      Dim folderPath As String
      Dim folder As Object
      Dim regex As Object
      Dim newName As String
      Dim currentName As String
      Dim num As String
      Dim delNum As String
     
      'ダイアログを表示してターゲット・フォルダーを指定
      With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a Folder"
            .AllowMultiSelect = False
            If .Show = -1 Then
                  folderPath = .SelectedItems(1)
                  folderPath = folderPath & "\"
            End If
      End With
     
      ' Create a FileSystemObject
      Set fso = CreateObject("Scripting.FileSystemObject")
       
      '正規表現の設定
      Set regex = CreateObject("VBScript.RegExp")
      regex.Pattern = "\(([0-9]{4})\)"
     
      ' ターゲット・フォルダー内のフォルダーをReName処理
      For Each folder In fso.GetFolder(folderPath).SubFolders
            ' 変名前のフォルダー名
            currentName = folder.Name
             
            '全角括弧を半角括弧に変換(フォルダー名内の括弧を半角に変換）
            currentName = ConvertKakko(currentName)
         
            ' 末尾の西暦部分を取り出す
            If regex.Test(currentName) Then
                  num = regex.Execute(currentName)(0).SubMatches(0)
            Else
                  num = ""
            End If
         
            '削除すべき西暦部（含む括弧）
            delNum = "(" & num & ")"
         
            'フォルダー名候補（変名前のフォルダー名から西暦部分を削除）
            newName = Replace(currentName, delNum, "")
         
            ' 変名後のフィルダー名（西暦 & フォルダー名候補）
            newName = num & " " & newName
         
            ' 変名
            folder.Name = newName
      Next folder
     
      ' Close処理
      Set fso = Nothing
End Sub
 
Public Function ConvertKakko(ByVal str As String) As String
    Dim i As Long
    Dim sZenList As String, sHanList As String
    Dim sZenAr(0 To 15) As String, sHanAr(0 To 15) As String
    Dim sKakkoZen As String, sKakkoHan As String
     
    sZenList = "（）［］｛｝〈〉《》「」『』【】〔〕"
    sHanList = "()[]{}<>≪≫\""""" ''[]"
     
    For i = 0 To 15
        sZenAr(i) = Mid(sZenList, i + 1, 1)
        sHanAr(i) = Mid(sHanList, i + 1, 1)
    Next
     
    sKakkoZen = "（）"
    sKakkoHan = "()"
     
    For i = 0 To 15
        str = Replace(str, sZenAr(i), sHanAr(i))
    Next
     
    ConvertKakko = Replace(str, sKakkoZen, sKakkoHan)
End Function

(1)
正規表現に関する情報源を、閲覧されている方の参考のために下記しておきます。
（リンクに関する文末の注意(*)を参照ください）
 
◆正規表現の概説はこちら。("VBScript.RegExp"で実装されている正規表現に限定されます)
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392149(v=msdn.10)
◆関連するオブジェクトのリファレンスはこちら。
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392403(v=msdn.10)
（プロパティやメソッドに関するリンクを利用して下さい。）
 
上記はマイクロソフトが示しているVBScriptに関する説明です。
いわば原典ですね。（私は上記の記事群を参照しています。)
（なお、ネット上にはより分かりやすい解説記事があるかもしれません。）
 
(2)
また、今回のReplaceメソッドの使い方に関しては、
上記概説の中に後方参照に関する以下の説明があります。
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392124(v=msdn.10)
> replace メソッドで $1 を指定すると、1 番目に保存されたサブマッチが参照されます。
> 複数のサブマッチが存在する場合、それらの文字列を参照するには $2、$3 などを指定します。
以下のReplaceメソッドの項にも、これを使った例文が示されています。
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392394(v=msdn.10)
 
# (*)
# (v=msdn.10)部分がリンクからはずれてしまうようなので、お手数ですが、コピーペイストして
# 利用してください。

URLの提供ありがとうございます。
 
以下のリンクですが、
テキストエディターにコピペしてリンク先に指定しましたが
全て「４０４-　ページが見つかりません」となります。
 
テキストエディターでは
(v=msdn.10)部分がリンクからはずれていないで一つのリンクとして認識されています。
 
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392149(v=msdn.10)
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392403(v=msdn.10)
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392124(v=msdn.10)
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392394(v=msdn.10)
 
マイクロソフトにサインインが必要ですか　？
 

リンクは下記で繋がるようです。
 
 
http://msdn.microsoft.com/ja-jp/library/cc392149
http://msdn.microsoft.com/ja-jp/library/cc392403
http://msdn.microsoft.com/ja-jp/library/cc392124
http://msdn.microsoft.com/ja-jp/library/cc392394
 

コメントありがとうございます。
私の名誉のためにコメントすると、
私の示したURLは、コピーペイスト（テキストエディタ経由も可）すれば、きちんと繋がるものです。
最後に提示されたURLは、リダイレクトされて結局は私の提示したURLに行き着きます。
まあ、簡単なURLのほうが良いともいえるが、
表示されている画面のURLをそのまま掲載した私の記載に間違いがあるわけではありません。
一応念のため。
 
なお、VBScript、JScript等に関するヘルプを集めたchmファイル（内容は上記と同等）を
MS社が提供しており、これはローカルで使えて便利なことを付記しておきます。
 
また、ここの閲覧者で正規表現を必要としている方は、限定的であることは承知しております。
ただ余り調べずに使われる方が時々いらっしゃる（今回というわけではない）ので、
良い機会と思い、情報源を示したまでです。

>私の示したURLは、コピーペイスト（テキストエディタ経由も可）すれば、きちんと繋がるものです。
 
 
 
もう一度試してみました。
 
私の利用しているテキストエディターは「EmEditor」ですが
URLはリンクとして認識していますが残念ながら繋がりません。
（全て「４０４-　ページが見つかりません」となります。）
 
いくつかのURLで確認しましたが
他のURLをコピペしたリンクは、普通に繋がりました。
 
私が利用しているプラウザがChromeなのが原因かも？
（Windowsの標準ブラウザであるMicrosoft Edgeでは、繋がるかもしれませんが試していません。）
 

Chromeで試してみましたが、
 

https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392149(v=msdn.10)

hatenaさん、どうもありがとうございました。
助かりました。名誉回復できました。
本筋でも無いこんなことで憂き目にあうとは想定外でした。
 
自分用のメモを調べたら、
「再生時間を削除して整形」投稿日時: 20/11/13 13:39:47投稿者: Nubo
の質問で、正規表現を巡る全く同様の議論をしていました。
なんとその時も、関連情報（MS社サイト、関連書籍３冊）の紹介をしていました。
（問われた訳でも無いのにお節介は昔からのようでしたww）
その際、他の回答者さんから「括弧だけURLエンコードされるとよいです」といった
指摘もいただいていたのですが、残念ながら活かせませんでした。
（自分が本当に困ったことでないと、記憶に定着するのは困難と改めて認識しました）

hatenaさん、試していただきありがとうございます。
 
>最後の()部分までコピーしてブラウザのURL欄に貼り付けたら、普通につながりました。
 
もう一度確認してみました。
 
当該URL(リンク）をコピペしてEmEditorに貼り付けると
見た目は最後の括弧（閉じるの括弧）まで問題なく貼り付けられていて
リンクとして機能しそうですが
良く見ると最後の括弧（閉じる括弧）がリンク範囲に無いので白文字で表記されていました。
（リンク範囲は、水色でアンダーバー付きと表記される）
 
添付画像では、見やすいように白文字部分を赤文字に塗り替えています。
 
https://imgur.com/pJgxpYJ
 
 
つまり、リンクして機能できない不完全な状態だと言う事です。
 
お騒がせしましたが、私の確認ミスでした。
simpleさんには不快な思いをさせて失礼しました。
 

simple さんの引用:
動作しているのですから基本的にOKだと思います。
 
あえて申し上げるとすると
ExtractNumberの中で、呼ばれる都度、正規表現objectを作るのは無駄のような気がします。
（モジュールベースの変数を使って、一度だけ作成することでよいと思います。
  尤も、ロスと言っても、数個程度であれば気にすることはないかとも思います。
  多数を相手にする場合は検討してみてください。)
 
以下は、こう書いたほうが良いということではなく、こういう書き方もあるという参考です。
 

Sub RenameFolders()
    Dim fso   As Object
    Dim folderPath As String
    Dim folder As Object
    Dim regex As Object

    'フォルダの指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            folderPath = folderPath & "\"
        End If
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    '正規表現の設定
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(.*?)[(（]([0-9]{4})[)）](.*?)"

    'サブフォルダのRename
    For Each folder In fso.GetFolder(folderPath).SubFolders
        If regex.test(folder.Name) Then
            folder.Name = regex.Replace(folder.Name, "$2 $1$3")
        End If
    Next folder
End Sub

なお、部品のテストを以下のように実行しました。

Sub test()
    Dim regex As Object
    Dim s1$, s2$, s3$
        
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(.*?)[(（](\d{4})[)）](.*?)" '全角カッコもあるものとしました
    
    s1 = "aaa(2023)"
    s2 = "aaa(2023)bbb"
    s3 = "(2023）aaa"
    
    Debug.Assert regex.Replace(s1, "$2 $1$3") = "2023 aaa"
    Debug.Assert regex.Replace(s2, "$2 $1$3") = "2023 aaabbb"
    Debug.Assert regex.Replace(s3, "$2 $1$3") = "2023 aaa"
    MsgBox "OK"
End Sub

# 気づいていないレアケースがあったら失礼。