【VBA】指定したフォルダのファイル一覧を取得、名前を一括で変更する方法

<スポンサーリンク>

名前一括変換の忘備録です。

【VBA】指定したフォルダのファイル一覧とリンクを取得

まずは、指定したフォルダのファイル一覧と、そのリンクを取得するプログラムで、
ファイル一覧を取得します。

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String
  
'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With
  
'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")
     
    Cells(2, 3).Value = "フォルダ⇒"
    Cells(2, 4).Value = "=HYPERLINK(""" & Path & """,""リンク"")"
    Cells(2, 5) = Path
      
      
'CELL B2からスタート。
      
      
   Cells(4, 2) = "No"
   Cells(4, 3) = "ファイル名"
   Cells(4, 4) = "リンク"
   Cells(4, 5) = "パス"
   Cells(4, 6) = "名前を変更したい場合↓"
       
     i = 4
      
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i - 4
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"
        Cells(i, 5).Value = LINK
  
        buf = Dir()
    Loop
     
    Columns(5).ShrinkToFit = True
 
     
  
End Sub

そのあと、F列に変更したい名前を入力し、
下記プログラムを実行することで、名前を変更します。
(.xlsxなどを入力しなくても、同様の拡張子をつけるようにif分岐させています)

Sub ファイル名前変更()
Dim buf As String
Dim i As Long
Dim Path As String
  
'フォルダの選択
    Path = Cells(2, 5)
     
    LASTY = Cells(Rows.Count, 3).End(xlUp).Row
 
    For i = 5 To LASTY
     
        If Cells(i, 6) <> "" Then
         
            OldName = Path & "\" & Cells(i, 3)
 
            '拡張子有り無しで分岐
            If InStr(1, Cells(i, 6), ".") > 0 Then
             
                NewName = Path & "\" & Cells(i, 6)
             
            Else
             
                KAKUCHOUSHI = Mid(Cells(i, 3), InStr(1, Cells(i, 3), "."))
                NewName = Path & "\" & Cells(i, 6) & KAKUCHOUSHI
             
            End If
         
            '名前の変更
            Name OldName As NewName
            Cells(i, 7) = "完了"
         
        End If
     
    Next
  
End Sub

【VBA】指定したフォルダのファイル一覧とリンクを取得

コメント欄