用 Excel VBA 快速獲取檔案路徑與批量改檔名

用Excel VBA 快速獲取檔案路徑與批量改檔名

這篇部落格文章介紹了兩個 Excel VBA 巨集，能幫助你快速處理檔案管理工作。第一個 VBA 讓你透過檔案選擇器批量獲取檔案路徑，並自動填入 Excel。第二個 VBA 則能根據 Excel 清單批次修改檔案名稱，並保留原始副檔名，確保文件格式不變。

選取文件並將其路徑導入至 Excel 工作表

功能解析

選取檔案：允許選取多個檔案。
將文件路徑填入 Excel：自動將所有選取文件的完整路徑填入 Excel 中的指定儲存格。
預留新名稱欄位：提供一個額外的欄位，讓使用者輸入新的文件名稱，便於後續更名操作。


Sub SelectFiles()
    Dim I As Long
    Dim xRg As Range
    Dim xAddress As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant

    On Error Resume Next
    
    xAddress = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("選取一個單元格:", "文件路徑導入", xAddress, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Set xRg = xRg(1)
    
    xRg.Value = "文件路徑"
    xRg.Offset(0, 1).Value = "新名稱"

    With xRg.Resize(1, 2).Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 12
    End With

    xRg.EntireColumn.AutoFit

    Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    xFileDlg.AllowMultiSelect = True 
    
    I = 1
    If xFileDlg.Show = -1 Then
        For Each xFileDlgItem In xFileDlg.SelectedItems
            xRg.Offset(I, 0).Value = xFileDlgItem 
            xRg.Offset(I, 1).Value = "" 
            I = I + 1
        Next
    End If

    Application.ScreenUpdating = True
End Sub

批量重新命名檔案

功能解析

批量修改文件名稱：根據 Excel 中的資料，逐一更改對應的檔案名稱。
保留原始副檔名：確保新名稱仍保留副檔名，不影響文件開啟。
檢查文件是否存在：若文件路徑錯誤，則顯示錯誤訊息。


Sub RenameFiles()
    Dim I As Long
    Dim xLastRow As Long
    Dim xFolderPath As String
    Dim xRgS, xRgD As Range
    Dim xOldPath, xOldName, xNewName, xExt As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set xRgS = Application.InputBox("選取要替換的文件路徑單元格:", "文件命名", , , , , , 8)
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("選取新名稱單元格:", "文件命名", , , , , , 8)
    If xRgD Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    xLastRow = xRgS.Rows.Count
    
    For I = 1 To xLastRow
        xOldPath = xRgS.Cells(I, 1).Value
        
        If fso.FileExists(xOldPath) Then
            xOldName = fso.GetFileName(xOldPath) 
            xNewName = xRgD.Cells(I, 1).Value
            
            xFolderPath = fso.GetParentFolderName(xOldPath) 
            xExt = fso.GetExtensionName(xOldPath) 
            
            fso.MoveFile xOldPath, xFolderPath & "\" & xNewName & "." & xExt 
        Else
            MsgBox "找不到文件路徑: " & xOldPath, vbExclamation, "錯誤"
        End If
    Next
    
    MsgBox "文件重新命名完成!", vbInformation, "完成"
    Application.ScreenUpdating = True
End Sub