VBA: 批量重命名文件夹和文件名称 |
您所在的位置：网站首页 › vba设置文件夹路径 › VBA: 批量重命名文件夹和文件名称 |
VBA: 批量重命名文件夹和文件名称
|
文章背景： 在工作中，有时需要将一些文件名称修改成特定的名称，如果文件比较多的话，手动修改费时费力，下面通过VBA代码实现批量操作。 1 Name函数2 应用示例2.1 批量修改文件夹的名称2.2 批量修改文件的名称 1 Name函数Name oldpathname As newpathname 重命名磁盘文件、目录或文件夹。 oldpathname Required. String expression that specifies the existing file name and location; may include directory or folder, and drive.Required. String expression that specifies the new file name and location; may include directory or folder, and drive. The file name specified by newpathname can't already exist.（1）Name 语句重命名文件，并在必要时将其移动到其他目录或文件夹。Name 可以在驱动器之间移动文件，但只有当 newpathname 和 oldpathname 位于同一驱动器上时，它才能重命名现有目录或文件夹。Name 无法创建新文件、目录或文件夹。 （2）Using Name on an open file produces an error. You must close an open file before renaming it. Name arguments cannot include multiple-character (*) and single-character (?) wildcards. 2 应用示例 假设要把test文件夹内所有文件（包括子文件夹）名称中的SH改为NB。 2.1 批量修改文件夹的名称(1) 获取所有子文件夹 表1 复制文件夹：  代码语言：javascript复制Option Explicit
Sub getSubFolderName()
'给定父文件夹名称，获取全部子文件夹名称
Dim folder As String, ii As Integer, arr() As String, tar_sheet As Worksheet
Dim fso As Object, fld As Object, subfld As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set tar_sheet = ThisWorkbook.Worksheets("1 复制文件夹")
folder = tar_sheet.Range("B1").Value2
ii = 0
If fso.FolderExists(folder) Then
Set fld = fso.getFolder(folder)
For Each subfld In fld.subFolders
If subfld.name Like "SH*" Then
ii = ii + 1
ReDim Preserve arr(1 To ii)
arr(ii) = subfld.name
End If
Next
Else
MsgBox "父文件夹不存在，请检查！"
Exit Sub
End If
If ii > 0 Then
tar_sheet.Range("A4").Resize(ii, 1) = Application.Transpose(arr)
End If
MsgBox "Done!已得到所有的子文件夹名称。"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub(2) 复制子文件夹，并删除旧的文件夹 代码语言：javascript复制Sub RenameFolder() '复制文件夹到新的路径，并删除旧的文件夹。 Dim row_final As Integer, ii As Integer, old_name As String, new_name As String Dim tar_sheet As Worksheet, fso As Object, root_path As String Set tar_sheet = ThisWorkbook.Worksheets("1 复制文件夹") row_final = tar_sheet.Range("A65535").End(xlUp).Row Set fso = CreateObject("Scripting.FileSystemObject") root_path = tar_sheet.Range("B1").Value2 If row_final > 3 Then For ii = 4 To row_final old_name = root_path & "\" & tar_sheet.Cells(ii, 1).Value2 new_name = root_path & "\" & tar_sheet.Cells(ii, 2).Value2 If Not isDirectory(new_name) Then fso.CopyFolder old_name, new_name Else MsgBox "文件夹已存在：" & new_name End If '删除旧文件夹 fso.DeleteFolder old_name Next ii End If MsgBox "Done!文件夹已重命名。" Exit Sub End Sub Function isDirectory(pathname As String) As Boolean '用于判断文件夹是否存在 Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") isDirectory = fso.FolderExists(pathname) End Function 2.2 批量修改文件的名称（1）获取所有文件的路径 表2 修改文件名：  新建一个模块，插入如下代码： 代码语言：javascript复制Option Explicit Option Base 1 Dim ArrName() As String, jj As Integer Sub getFileName() '给定父文件夹名称，获取全部子文件的路径 Dim folder As String, fso As Object, fld As Object, tar_sheet As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False Set tar_sheet = ThisWorkbook.Worksheets("2 修改文件名") Set fso = CreateObject("Scripting.FileSystemObject") jj = 0 folder = tar_sheet.Range("B1").Value2 If fso.FolderExists(folder) Then Set fld = fso.getFolder(folder) LookUpAllFiles fld Else MsgBox "父文件夹不存在，请检查！" Exit Sub End If If jj > 0 Then tar_sheet.Range("A4").Resize(jj, 1) = Application.Transpose(ArrName) Erase ArrName End If MsgBox "Done!已得到所有子文件的路径。" Application.ScreenUpdating = True Application.DisplayAlerts = True Exit Sub End Sub Sub LookUpAllFiles(fld As Object) '遍历文件 Dim file As Object, outFld As Object For Each file In fld.Files jj = jj + 1 ReDim Preserve ArrName(1 To jj) ArrName(jj) = fld.Path & "\" & file.Name Next For Each outFld In fld.subFolders LookUpAllFiles outFld '递归法，调用自身 Next End Sub因为 Name 无法创建文件夹，所以在2.1节中，先复制子文件夹，为后续Name语句的使用做准备。 （2）批量修改文件名称 代码语言：javascript复制Sub RenameFiles() '重命名文件 Dim kk As Integer, row_Namefinal As Integer, tar_sheet As Worksheet Dim arr_Name() As String, old_name As String, new_name As String Set tar_sheet = ThisWorkbook.Worksheets("2 修改文件名") row_Namefinal = tar_sheet.Range("A65535").End(xlUp).Row ReDim arr_Name(1 To row_Namefinal, 1 To 2) '临时存储文件名称 With tar_sheet For kk = 4 To row_Namefinal arr_Name(kk, 1) = .Cells(kk, 1).Value2 arr_Name(kk, 2) = .Cells(kk, 2).Value2 Next kk End With '文件重命名 If row_Namefinal > 3 Then For kk = 4 To row_Namefinal old_name = arr_Name(kk, 1) new_name = arr_Name(kk, 2) Name old_name As new_name Next kk End If MsgBox "Done！已完成所有文件重命名！" Exit Sub End Sub 参考资料： [1] 批量重命名文件/文件夹（https://zhuanlan.zhihu.com/p/52484779） [2] Name statement（https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/name-statement） [3] Name 语句（https://learn.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/name-statement） [4] 如何用vba删除文件夹（http://www.exceloffice.net/archives/1510） [5] DeleteFolder method（https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/deletefolder-method） |
【本文地址】
今日新闻 |
推荐新闻 |