置顶公众号，否则不能及时收到新文章

推荐给朋友，让朋友也能收到免费文章

在公众号发送函数或应用的关键字，即可免费获取对应教程

一、功能说明我们在日常办公的时候，经常会碰到文件名不规范，想要整理很不方便，如果一个个修改文件或者文件夹名称吧，很麻烦。本工具就是用VBA实现，先提取原文件或文件夹名，然后把想我名字先输入到工作表中，再运行就可以完成修改名称了。二、使用说明运行“文件(夹)批量改名”工作簿，就会打开工作表，在工作表中制作了按钮。先点“名称列表”，提取原文件或文件夹名到A列，然后在B列输入想要的名称，再点“批量改名”按钮就自动完成了文件或文件夹名称的批量修改了。注意：如果是要批量修改文件名，就在“改名设置”栏下面选“文件改名”选项；果是要批量修改文件夹名，就在“改名设置”栏下面选“文件夹改名”选项。

三、主要代码1、文件批量改名代码：

Sub 列出所有文件名()    Dim A%, X%        On Error GoTo AAA        A = [A65536].End(xlUp).Row    If A > 1 Then: Range("A2:B" & A).ClearContents    Dim xlsFile As String, XX As String    XX = Range("C2").Text    xlsFile = Dir(ActiveWorkbook.Path & "\" & XX)    Do        If InStr(1, xlsFile, ThisWorkbook.Name) = 0 Then            Cells(([A65536].End(xlUp).Row + 1), 1) = xlsFile        End If        xlsFile = Dir            Loop Until Len(xlsFile) = 0    X = Range("A65536").End(xlUp).Row    Range(Range("B2"), Range("B" & X)).Value = Range(Range("A2"), Range("A" & X)).Value    MsgBox "完成"    Exit SubAAA:    MsgBox "没有该类型的文件，请重新选择文件类型试试！"End SubSub 文件批量改名()    Dim X%, Y%    X = [A65536].End(xlUp).Row    On Error Resume Next    For Y = 2 To X        If Cells(Y, 2) <> "" Then            Name ActiveWorkbook.Path & "\" & Cells(Y, 1) As ActiveWorkbook.Path & "\" & Cells(Y, 2)        End If    Next    MsgBox "完成"End Sub

2、文件夹批量改名代码：

Sub 列出所有文件夹名()    On Error Resume Next    Dim A%, X%    Dim dd As String    Dim k%    On Error Resume Next        A = Range("A65536").End(xlUp).Row    If A > 1 Then: Range("A2:B" & A).ClearContents    Dim xlsFile As String, XX As String    XX = Range("C2").Text    ''提取文件夹名称    dd = Dir(ThisWorkbook.Path & "\*", vbDirectory)    Do        dd = Dir        ''判断是否为文件夹        If dd <> "" And InStr(1, dd, ".") = 0 Then            Dim aa            Set aa = CreateObject("Scripting.FileSystemObject")            k = k + 1            Cells((Range("A65536").End(xlUp).Row + 1), 1) = dd        End If    Loop Until Len(dd) = 0    If k = 0 Then: GoTo BBB    X = Range("A65536").End(xlUp).Row    Range(Range("B2"), Range("B" & X)).Value = Range(Range("A2"), Range("A" & X)).Value    MsgBox "完成"    Exit SubBBB:    MsgBox "没有文件夹，请你新建几个文件夹试试！"    Set aa = NothingEnd SubSub 文件夹批量改名()    Dim X%, Y%    X = Range("A65536").End(xlUp).Row    On Error Resume Next    Set aa = CreateObject("Scripting.FileSystemObject")    For Y = 2 To X        If Cells(Y, 2) <> "" Then            ''文件夹重命名            aa.MoveFolder ThisWorkbook.Path & "\" & Cells(Y, 1), ThisWorkbook.Path & "\" & Cells(Y, 2)        End If    Next    Set aa = Nothing    MsgBox "完成"End Sub

3、工作表内按钮代码：

Sub 名称列表()    With Sheet1.Range("C3")        If .Value = 1 Then            Call 列出所有文件名        Else            Call 列出所有文件夹名        End If    End WithEnd SubSub 批量改名()    With Sheet1.Range("C3")        If .Value = 1 Then            Call 文件批量改名        Else            Call 文件夹批量改名        End If    End WithEnd SubSub 文件改名_单击()    ActiveSheet.Shapes("文件类型").Visible = TrueEnd SubSub 文件夹改名_单击()    ActiveSheet.Shapes("文件类型").Visible = FalseEnd Sub

四、工具下载关注本公众号后，在公众号聊天窗口发送XSS002，系统会自动回复给你下载地址。

如果你是新朋友，长按下面二维码 --> 前往图中包含的公众号 --> 关注公众号，就可以跟谢顺胜一起研究Excel在工程中的应用了。

微信公众号(ID:ExcelGcYy)

个人微信号(ID: hhzjxss)

进入公众号发送函数或工程应用的名称关键词，即可免费获得相关教程

---

本公众目前未能提供下载，如果需要下载Excel文件的，可以加入【Excel工程应用技巧群】QQ群(218089918)，到群文件夹中下载文件。