【Excel VBA】ファイル名変更マクロ▽ソースコード

《操作》

（１）メニューの開発→マクロから、「Aフォルダー指定マクロ」を選択して実行。ファイル名を変更したいフォルダーを選択します。

図１

図２

（２）メニューの開発→マクロから、「Bファイル名検索マクロ」を選択して実行。指定したフォルダーのファイル名をＣ列に取り込みます。

図3

（３）変更したいファイル名をＤ列「変更ファイル名（入力）」に手入力します。その時、セルが空欄であれば、ファイル名は変更されません。また、Ｄ列に入力するデータは数式があっても構いません。ちなみに、図４は、［="SAMP" & TEXT(ROW()-2,"000") & ".txt"］と入力しています。

図４

（４）メニューの開発→マクロから、「Cファイル名変更マクロ」を選択して実行。正常にファイル名が変更されると、変更処理結果に［〇］が付きます。ファイル名が不正であったり、すでにあるファイル名を指定して、ファイル名が正常に変更されないと［×］が付きます。

図５

Option Explicit

Option Base 0

'

Const FLDRCELL = "C1"        'フォルダー格納セル

Const FILTERSS = "*.*"        'ファイル名検索フィルター

Const FLSTFROW = 3           '検索ファイル名格納先頭行

Const FLSTFCOL = 3            '検索ファイル名格納カラム

Const NLSTFCOL = 4            '新規ファイル名格納カラム

Const MARKFCOL = 5           '変更処理結果格納カラム

'

Const FLSTMXRW = 100 　　'最大ファイル処理数

Public Sub Aフォルダー指定マクロ()

    Dim strPath As String

    '

    With Application.FileDialog(msoFileDialogFolderPicker)

         If .Show = 0 Then

            Application.StatusBar = "フォルダー指定を取り消しました."

            Exit Sub

          End If

     　  strPath = .SelectedItems(1)

    End With

  '

    ActiveSheet.Cells.Range(FLDRCELL).Value = strPath

    Application.StatusBar = "フォルダー指定をしました"

End Sub

Public Sub Bファイル名検索マクロ()

    Dim strPat As String, strDir As String

    Dim Ip As Integer

    '

    With ActiveSheet

         '*ファイル格納行をクリア

         For Ip = 0 To FLSTMXRW - 1

             .Rows(FLSTFROW + Ip).Clear

         Next Ip

         '

         If Trim(.Cells.Range(FLDRCELL).Value) = "" Then

            Application.StatusBar = "フォルダーの指定がありません."

            Exit Sub

         End If

         '

         '検索ファイル名

         strPat = .Cells.Range(FLDRCELL).Value & "\" & FILTERSS

         strDir = Dir(strPat)

         Ip = 0

         Do While strDir <> ""

           .Cells(FLSTFROW + Ip, FLSTFCOL).Value = strDir

            Ip = Ip + 1

            strDir = Dir()

         Loop

     End With

    Application.StatusBar = Str(Ip) & "個のファイルを見つけました"

End Sub

Public Sub Cファイル名変更マクロ()

    Dim strPat As String, strOFn As String

    Dim strNFn As String

    Dim Ip As Integer, IErr As Integer

    Dim intPcn(1) As Integer

    '

    With ActiveSheet

         If .Cells.Range(FLDRCELL).Value = "" Then

             Application.StatusBar = "フォルダーの指定がありません."

             Exit Sub

         End If

         '

         On Error GoTo ファイル変更マクロ_ERROR

         intPcn(0) = 0: intPcn(1) = 0

         For Ip = 0 To FLSTMXRW - 1

             If Trim(.Cells(FLSTFROW + Ip, FLSTFCOL).Value) <> "" _

         And Trim(.Cells(FLSTFROW + Ip, NLSTFCOL).Value) <> "" Then

                strOFn = .Cells.Range(FLDRCELL).Value & "\" & _

                         Trim(.Cells(FLSTFROW + Ip, FLSTFCOL).Value)

                strNFn = .Cells.Range(FLDRCELL).Value & "\" & _

                         Trim(.Cells(FLSTFROW + Ip, NLSTFCOL).Value)

                IErr = 0

                Name strOFn As strNFn

                intPcn(IErr) = intPcn(IErr) + 1

                .Cells(FLSTFROW + Ip, MARKFCOL).Value = _

                                                IIf(IErr = 0, "〇", "×")

             End If

         Next Ip

    End With

    Application.StatusBar =  _Str(intPcn(0)) &  _

   "個のファイル名を変更しました.(NG:" & intPcn(1) & "個)"

    Exit Sub

'

ファイル変更マクロ_ERROR:

    IErr = 1

    Resume Next

End Sub