Excel VBA批量修改文件夾下的文件名


今天,有同事提出想批量修改文件名,規則比較簡單,在第五位后加“-”即可,

上網沒找到相關工具,就自己做了個excel,用宏代碼修改。

代碼如下:

Private Sub CommandButton1_Click()

Dim varFileList As Variant

MsgBox "選擇要重命名文件所在的文件夾,點擊確定!"

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
   
    If .SelectedItems.Count = 0 Then Exit Sub '未選擇文件夾
   
    renamepath = .SelectedItems(1)
   
    If Right(renamepath, 1) <> "\" Then
        renamepath = renamepath + "\"
    End If
End With

'獲取文件夾中的所有文件列表
varFileList = fcnGetFileList(renamepath)

If Not IsArray(varFileList) Then
    MsgBox "未找到文件", vbInformation
    Exit Sub
End If

For l = 0 To UBound(varFileList)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    oName = renamepath & CStr(varFileList(l))
    If fs.FileExists(oName) And Len(CStr(varFileList(l))) > 5 Then
        nName = renamepath & Left(CStr(varFileList(l)), 5) & "-" & Mid(CStr(varFileList(l)), 6)
        Name oName As nName
    End If
Next l

MsgBox "全部修改成功!哈哈", vbInformation

End Sub

Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
' 將文件列表放到數組
Dim f As String
Dim i As Integer
Dim FileList() As String

If strFilter = "" Then strFilter = "*.*"
    Select Case Right(strPath, 1)
    Case "\", "/"
    strPath = Left(strPath, Len(strPath) - 1)
End Select

ReDim Preserve FileList(0)
f = Dir(strPath & "\" & strFilter)
Do While Len(f) > 0
    ReDim Preserve FileList(i) As String
    FileList(i) = f
    i = i + 1
    f = Dir()
Loop
If FileList(0) <> Empty Then
    fcnGetFileList = FileList
Else
    fcnGetFileList = False
End If

End Function

 

 

 


免責聲明!

本站轉載的文章為個人學習借鑒使用,本站對版權不負任何法律責任。如果侵犯了您的隱私權益,請聯系本站郵箱yoyou2525@163.com刪除。



 
粵ICP備18138465號   © 2018-2025 CODEPRJ.COM