VLOOKUP関数的にファイルリネームを行う

VLOOKUP関数的に、いわゆる「表引き」でファイル名のリネームを行うファイルリネームソフト（もどき）を作ってみました。

概要
プログラムの流れ
コード本体
引数なしのDir関数の振る舞い
お好みで機能を変更する

概要

例えばこのように、とある商品の設計資料があったとして、ファイル名が商品コードのみであったとします。

f:id:kouten0430:20180507084400j:plain

これでは、ぱっと見、各ファイルがどの商品のものなのか分かりづらいですよね？かといって、いちいち手作業でファイル名を直していられるほど現代人は暇ではありません。なので、エクセルのリストとマクロを使ってファイル名に商品名を追記してみたいと思います。
リストが存在することが前提ですが、例えば、商品コード「1000」に一致するファイル名に、同じ行の左端からn列目（仮に2列目とする）の値を挿入し、ファイル名を「1000めぐすり」に変更します。

f:id:kouten0430:20180507084505j:plain

同じように、商品コードの列を垂直方向に検索していき、一致する同じ行のn列目の値をファイル名に挿入していきます。

f:id:kouten0430:20180507084906j:plain

こんな感じで、変更前に比べて各ファイルが何の商品のものなのか、ぱっと見で、分かりやすくなりました。

これくらいのファイル数なら、手作業でもできますが、仮に数百ファイルあった場合、手作業でやろうとすると、茨の道を歩むことになります。（試しにマクロで1,000ファイルリネームしてみたところ、1秒かからずに完了しました）

プログラムの流れ

どのフォルダのファイル群に対して処理を行うのかを選択します。
VLOOKUP関数的に「表引き」を行う矩形範囲を選択します。
選択した範囲が下図のように配列に格納されます。（画像はイメージ）
選択範囲の左端から数えて何列目から表引きするかを指定します。
左端の値を用いてフォルダー内を部分一致条件で検索し、一致したファイル名を取得します。
Nameステートメント（Name 元のファイル名〔取得したファイル名〕　As 変更後のファイル名〔元のファイル名 + 配列のn列目の値〕）で、リネームします。
5～6を二次元配列の1次元（範囲の左端）の最大値までループします。

コード本体

Sub VLOOKUP関数的ファイルリネーム()
    Dim Dn As String
    Dim Tdim As Variant
    Dim n As Variant
    Dim i As Integer
    Dim Fn As String
    Dim p As Integer
    Dim ct As Integer
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "リネーム作業を行うフォルダーを選択して下さい"
        
        If .Show = -1 Then
            Dn = .SelectedItems(1)
        Else
            Exit Sub
        End If
    
    End With
    
    Tdim = Application.InputBox(prompt:="範囲の左端の値でファイル名を検索し、一致したファイルには、" & vbCrLf & _
    "同じ行の左端からn列目の値をファイル名の末尾に挿入します。" & vbCrLf & "（検索は部分一致で行われます）", Title:="矩形範囲を選択して下さい", _
    Type:=8) '選択された範囲を二次元配列に格納する
        If TypeName(Tdim) = "Boolean" Then  'キャンセルを押された場合の処理
            Exit Sub
        End If
        
    n = Application.InputBox(prompt:="nを指定します。（左端を1列目とします）", Title:="数値を入力して下さい", Type:=1)
        If TypeName(n) = "Boolean" Then  'キャンセルを押された場合の処理
            Exit Sub
        End If

    For i = 1 To UBound(Tdim)   '二次元配列の一次元の最大値までループ
        If Not IsEmpty(Tdim(i, 1)) Then
            Fn = Dir(Dn & "\*" & Tdim(i, 1) & "*")    'フォルダー内を部分一致条件で検索し、一致したファイル名を取得（なければ空白が返る）
        
            Do Until Fn = ""    'ファイル名が空白になるまでループ
                p = InStrRev(Fn, ".")  '.を後方から検索して最初に見つかった文字位置（先頭からの文字数）を返す
                Name Dn & "\" & Fn As Dn & "\" & Application.WorksheetFunction.Replace(Fn, p, 0, Tdim(i, n))  '元のファイル名と拡張子の間に、n列目の値を挿入する
                ct = ct + 1
                Fn = Dir()  '検索一致が複数あった場合の、二つ目以降のファイル名を取得（なければ空白が返る）
            Loop
        End If
        
    Next i
    
    MsgBox "処理成功：" & ct & " ファイル"

End Sub

※SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

引数なしのDir関数の振る舞い

Dir関数でファイル名を検索し、検索結果が複数あった場合のために、引数なしのDir()をループの中に配置します。
Dir()は、2個目以降の検索結果を、ループで順番に吐き出し、検索結果がなくなれば空白（長さ0の文字列）を吐き出してくれます。が、処理によっては困ったことが発生しました。
ローカルウィンドウ等で観察した上での推定ですが、Dir()は名前順でファイル名を検索しているようで、ループ処理の中で名前順が変わってしまうようなリネームを行うと、同じファイルを2度検索してしまうようなのです。
ファイル名末尾への文字挿入やファイル名すべてを変更するリネームでは、名前順が変わらない、または、2度目の検索に一致しないため問題ないようですが、ファイル名先頭への文字挿入で不具合が起こります。
同じ人が変装して、同じ列に何回も並ぶようなもの（？）でしょうか。

f:id:kouten0430:20180507090004j:plain