Excel·VBA文件重命名、移动

薛定谔_51

已于 2024-01-06 11:17:22 修改

阅读量6.9k

点赞数 4

分类专栏： VBA # Excel 文章标签： excel vba

于 2022-12-13 20:37:08 首次发布

本文链接：https://blog.csdn.net/hhhhh_51/article/details/128307273

版权

Excel 同时被 2 个专栏收录

79 篇文章 71 订阅

订阅专栏

VBA

76 篇文章 26 订阅

订阅专栏

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，批量移动文件

5.1，移动所有文件至目标文件夹

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

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

5.2，移动文件至目标文件夹指定子文件夹_读取表格数据

与方法2一样的形式，先使用方法2读取需要移动的文件名，再编辑对应的目标子文件夹，运行代码即可移动文件

Sub 移动文件至子文件夹_读取表格数据()
    '子文件夹不存在则创建，并判断目标子文件夹是否包含该文件
    Dim file_path$, target_path$, save_path$, i&
    file_path = "E:\测试\移动文件\文件\"  '待移动文件所在文件夹
    target_path = "E:\测试\移动文件\目标文件夹\"  '移动文件目标文件夹
    arr = [a1].CurrentRegion.Value  '获取表格数据，A列为文件名，B列为子文件夹名
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(target_path) Then .CreateFolder (target_path)  '创建
        For i = 2 To UBound(arr)
            f = arr(i, 1): save_path = target_path & arr(i, 2) & "\" '子文件夹路径
            If Not .FolderExists(save_path) Then .CreateFolder (save_path)
            If Not .FileExists(save_path & f) Then  '文件不存在
                .movefile file_path & f, save_path
            Else
                Debug.Print "移动失败，目标文件夹已存在该文件：" & f
            End If
        Next
    End With
    Debug.Print "文件移动完成"
End Sub

测试：10个人每人4个文件，共40个文件，所在文件夹为file_path

目标子文件夹也可不事先创建，代码会自动创建，所在文件夹为target_path

待移动文件文件名，及其对应的目标子文件夹名称
测试结果：全部移动成功

5.3，移动文件至目标文件夹指定子文件夹_按文件夹名称查找

当然也可不通过Excel表格编辑对应的目标子文件夹，代码自动读取文件名和子文件夹名称，文件名称中包含子文件夹名称的，则自动移动文件至子文件夹
与方法5.2不同的是，如果目标子文件夹不存在，则不移动对应的文件
以下代码调用了《Excel·VBA数组冒泡排序函数》bubble_sort_arr函数，对子文件夹名称按其字数降序排序，避免移动错误，详见举例说明（如需使用代码需复制）

Sub 按名称移动文件至子文件夹_按文件夹名称查找()
    '按文件夹名称查找，如果待移动文件中不包含该文件夹名称，则不会移动
    '需按子文件夹名字数降序排序，否则如果2个子文件夹名称之间存在包含关系，则会导致移动位置错误
    Dim fso As Object, file_path$, target_path$, save_path$, i&, j&, f, s$
    file_path = "E:\测试\移动文件\文件\"  '待移动文件所在文件夹
    target_path = "E:\测试\移动文件\目标文件夹\"  '移动文件目标文件夹
    Set fso = CreateObject("Scripting.FileSystemObject"): delimiter = Chr(28)
    For Each f In fso.GetFolder(file_path).Files  '获取所有文件名
        s = s & delimiter & f.Name
    Next
    frr = Split(Mid(s, 2), delimiter): s = ""  'frr数组记录文件名
    For Each f In fso.GetFolder(target_path).SubFolders  '获取所有子文件夹名
        s = s & delimiter & f.Name
    Next
    fd = Split(Mid(s, 2), delimiter): ReDim prr(1 To UBound(fd) + 1, 1 To 2)
    For Each f In fd
        i = i + 1: prr(i, 1) = f: prr(i, 2) = Len(f)  'prr数组记录子文件夹名及其长度
    Next
    prr = bubble_sort_arr(prr, 2, "-")  '按子文件夹名字数排序，降序
    For i = 1 To UBound(prr)  '从文件夹名称查找，待移动的文件名中是否包含字符
        s = prr(i, 1): save_path = target_path & s & "\"   '子文件夹路径
        For j = LBound(frr) To UBound(frr)
            If InStr(frr(j), s) > 0 Then   '文件名包含子文件夹名，移动文件
                fso.movefile file_path & frr(j), save_path
                frr(j) = ""  '已移动文件删除数组
            End If
        Next
    Next
    Debug.Print "文件移动完成"
End Sub

测试：10个人每人4个文件，共40个文件，所在文件夹为file_path

目标子文件夹必须事先创建，否则文件不会移动，所在文件夹为target_path
注意常青和吴明2个文件夹，如果代码中未使用bubble_sort_arr函数进行降序排序，那么会导致原属常青云的文件被移动至常青文件夹，吴明晋同理
测试结果：全部移动成功

6，批量创建文件夹

如果待创建的文件夹名称包含非法字符，即

\/:*?"<>|

则无法创建，可参考《Excel·VBA按列拆分工作表、工作簿》调用RE_STR函数清除

Sub 批量创建文件夹()
    '在指定文件夹下创建多个指定名称的文件夹，文件夹已存在2种方法都会报错
    Dim file_path$, name_path, temp$, n
    file_path = "E:\测试\重命名\"  '待创建文件夹所在的文件夹
    'name_path = Array("高举", "李丝雅", "梁存厚", "黄秉坤", "吴明晋", "林铭", "李洛由", "高舜钦", "吕易忠", "常青云")
    name_path = [a1].CurrentRegion.Value  '从表格读取数据，单行单列多行多列都可
'--------------------mkdir实现方法
'    For Each n In name_path
'        If Len(n) Then MkDir (file_path & "\" & n)
'    Next
'--------------------fso实现方法，加入判断文件夹是否存在
    With CreateObject("Scripting.FileSystemObject")
        For Each n In name_path
            If Len(n) Then
                temp = file_path & "\" & n
                If Not .FolderExists(temp) Then .CreateFolder (temp)
            End If
        Next
    End With
    Debug.Print "文件夹创建完成"
End Sub