目录

• • 1，获取文件夹下所有文件名
  • 2，获取文件夹下所有文件名并重命名
  • 3，按顺序重命名
  • • 3.1，重命名为序号
    • 3.2，文件名前添加序号
  • 4，简体/繁体文件名重命名
  • 5，批量移动文件

1，获取文件夹下所有文件名

Sub 测试代码()Dim i&, j&file_path = "E:\测试\重命名"With CreateObject("Scripting.FileSystemObject")For Each f In .GetFolder(file_path).Files  '遍历文件夹里文件i = i + 1: Cells(i, 1).Value = f.NameNextEnd Withfile_name = Dir(file_path & "\*")Do While file_name <> ""j = j + 1: Cells(j, 3).Value = file_namefile_name = DirLoop
End Sub

2种代码获取文件名，结果一致

2，获取文件夹下所有文件名并重命名

Dim fso As Object, file_path$, gfd, f     '公共变量
Sub 获取文件夹下所有文件名()file_path = "E:\测试\重命名"  '指定文件夹Range("A:B").ClearContents   '仅清空数据[a1].Resize(1, 2) = Array("原文件名", "新文件名"): i = 1Set fso = CreateObject("Scripting.FileSystemObject")  '文件访问对象Set gfd = fso.GetFolder(file_path)  '获取文件夹对象For Each f In gfd.Filesi = i + 1: Cells(i, 1).Value = f.NameNextDebug.Print "获取文件夹下所有文件名，已完成"
End SubSub 对获取的文件重命名()'注意避免新旧文件名有重复的，否则可能报错If [a2] = "" Then Debug.Print "请先执行第一步": Exit Subi = 1For Each f In gfd.Files  '遍历文件夹里的所有文件i = i + 1: f.Name = Cells(i, 2).Value  '将原文件名改成B列对应的新文件名NextDebug.Print "文件重命名，已完成"
End SubSub 文件重命名()'对固定文件夹中文件重命名，适用以上sub获取的文件名（只要文件存在即可）Dim arr, i&, file_path$, olddir$, newdir$arr = [a1].CurrentRegion.Valuefile_path = "E:\测试\重命名"  '指定文件夹For i = 2 To UBound(arr)olddir = file_path & "\" & arr(i, 1)newdir = file_path & "\" & arr(i, 2)Name olddir As newdirNextDebug.Print "文件重命名，已完成"
End Sub

2种代码重命名文件名，结果一致

3，按顺序重命名

对文件夹下文件按顺序重命名

3.1，重命名为序号

Sub 文件名批量重命名顺序序号()'批量重命名文件夹中文件的文件名，按顺序序号重命名Dim length&, file_path$, file_name$, c&, fso As Objectlength = 4       '序号位数，即序号最少位数file_path = "E:\测试\重命名"  '待重命名文件所在的文件夹file_name = Dir(file_path & "\*")  '*后可指定文件扩展名str_0 = WorksheetFunction.Rept("0", length)  'length位0的字符串Set fso = CreateObject("Scripting.FileSystemObject")Do While file_name <> ""c = c + 1olddir = file_path & "\" & file_namenewdir = file_path & "\" & Format(c, str_0) & "." & fso.GetExtensionName(file_name)If olddir <> newdir Then Name olddir As newdirfile_name = Dir  '下一个文件名LoopDebug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub

3.2，文件名前添加序号

Sub 文件名前批量添加序号()'批量重命名文件夹中文件的文件名，按顺序在文件名前添加固定位数序号Dim length&, delimiter$, file_path$, file_name$, c&length = 4       '序号位数，即添加的序号最少位数delimiter = "_"  '分隔符，序号与原文件名之间，也可以为空file_path = "E:\测试\重命名"  '待重命名文件所在的文件夹file_name = Dir(file_path & "\*")  '*后可指定文件扩展名str_0 = WorksheetFunction.Rept("0", length)  'length位0的字符串Do While file_name <> ""c = c + 1olddir = file_path & "\" & file_namenewdir = file_path & "\" & Format(c, str_0) & delimiter & file_nameName olddir As newdirfile_name = Dir  '下一个文件名LoopDebug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub

4，简体/繁体文件名重命名

中文简体/繁体互转函数

#If Win64 ThenPrivate Declare PtrSafe Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As LongPrivate Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#ElseIf Win32 ThenPrivate Declare Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As LongPrivate Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#End IfFunction chs2cht(ByVal str As String) As String'简体转繁体Dim str_len&, cht$str_len = lstrlen(str)  '指定字符串的长度cht = Space(str_len)    '相同长度的空字符串LCMapString &H804, &H4000000, str, str_len, cht, str_lenchs2cht = cht
End FunctionFunction cht2chs(ByVal str As String) As String'繁体转简体，有一些繁体字无法转换Dim str_len&, chs$str_len = lstrlen(str)  '指定字符串的长度chs = Space(str_len)    '相同长度的空字符串LCMapString &H804, &H2000000, str, str_len, chs, str_lencht2chs = chs
End Function

文件夹下所有文件名繁体转简体

Sub 文件夹下所有文件名繁体转简体()Dim file_path$, file_name$file_path = "E:\测试\重命名"  '待重命名文件所在的文件夹file_name = Dir(file_path & "\*")  '*后可指定文件扩展名Do While file_name <> ""olddir = file_path & "\" & file_namenewdir = file_path & "\" & cht2chs(file_name)Name olddir As newdirfile_name = Dir  '下一个文件名LoopDebug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub

转换效果一般，部分繁体字无法转换

5，批量移动文件

批量移动指定文件夹下文件至目标文件夹

Sub 文件夹下文件移动至指定文件夹()'仅移动文件，不移动子文件夹；old_path、new_path必须以\结尾Dim old_path$, new_path$, ext$, fold_path = "E:\测试\重命名\1\"new_path = "E:\测试\重命名\2\"ext = "xls*"  '仅移动指定扩展名，可使用通配符，*为所有文件With CreateObject("Scripting.FileSystemObject")If Not .FolderExists(old_path) Then Debug.Print "文件夹不存在": Exit SubIf Not .FolderExists(new_path) Then .CreateFolder (new_path)For Each f In .GetFolder(old_path).Files  '遍历文件夹里文件If .GetExtensionName(f.Name) Like ext ThenIf Not .FileExists(new_path & f.Name) Then  '文件不存在'.movefile old_path & f.Name, new_path  '2种移动等价f.Move (new_path)ElseDebug.Print "移动失败，目标文件夹已存在该文件：" & f.NameEnd IfEnd IfNextEnd WithDebug.Print "文件夹所有文件移动完成"
End Sub