Excel·VBA文件重命名

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.Name
        Next
    End With
    
    file_name = Dir(file_path & "\*")
    Do While file_name <> ""
        j = j + 1: Cells(j, 3).Value = file_name
        file_name = Dir
    Loop
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 = 1
    
    Set fso = CreateObject("Scripting.FileSystemObject")  '文件访问对象
    Set gfd = fso.GetFolder(file_path)  '获取文件夹对象
    For Each f In gfd.Files
        i = i + 1: Cells(i, 1).Value = f.Name
    Next
    Debug.Print "获取文件夹下所有文件名，已完成"
End Sub

Sub 对获取的文件重命名()
    '注意避免新旧文件名有重复的，否则可能报错
    If [a2] = "" Then Debug.Print "请先执行第一步": Exit Sub
    i = 1
    For Each f In gfd.Files  '遍历文件夹里的所有文件
        i = i + 1: f.Name = Cells(i, 2).Value  '将原文件名改成B列对应的新文件名
    Next
    Debug.Print "文件重命名，已完成"
End Sub

Sub 文件重命名()
    '对固定文件夹中文件重命名，适用以上sub获取的文件名（只要文件存在即可）
    Dim arr, i&, file_path$, olddir$, newdir$
    arr = [a1].CurrentRegion.Value
    file_path = "E:\测试\重命名"  '指定文件夹
    For i = 2 To UBound(arr)
        olddir = file_path & "\" & arr(i, 1)
        newdir = file_path & "\" & arr(i, 2)
        Name olddir As newdir
    Next
    Debug.Print "文件重命名，已完成"
End Sub

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

3，按顺序重命名

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

3.1，重命名为序号

Sub 文件名批量重命名顺序序号()
    '批量重命名文件夹中文件的文件名，按顺序序号重命名
    Dim length&, file_path$, file_name$, c&, fso As Object
    length = 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 + 1
        olddir = file_path & "\" & file_name
        newdir = file_path & "\" & Format(c, str_0) & "." & fso.GetExtensionName(file_name)
        If olddir <> newdir Then Name olddir As newdir
        file_name = Dir  '下一个文件名
    Loop
    Debug.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 + 1
        olddir = file_path & "\" & file_name
        newdir = file_path & "\" & Format(c, str_0) & delimiter & file_name
        Name olddir As newdir
        file_name = Dir  '下一个文件名
    Loop
    Debug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub

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

中文简体/繁体互转函数

#If Win64 Then
    Private 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 Long
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#ElseIf Win32 Then
    Private 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 Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
#End If

Function 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_len
    chs2cht = cht
End Function

Function 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_len
    cht2chs = 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_name
        newdir = file_path & "\" & cht2chs(file_name)
        Name olddir As newdir
        file_name = Dir  '下一个文件名
    Loop
    Debug.Print "该文件夹下所有文件重命名处理完成：" & file_path
End Sub

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

5，批量移动文件

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

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