Excel vba批量提取文件名+修改文件名！

1、首先新建一个excel文件，然后打开该excel，接着，按F12另存为xlsm格式的文件，如下图所示：

2、打开另存的文件xlsm，然后按ALT+F11，打开宏编辑界面，如下图所示：

3、接下来找到thisworkbook的模块，然后将如下的代码，复制粘贴到指定的模块中，如下图所示：代码：Sub 批量获取文件名(像粜杵泳)Cells = ""Dim sfsoDim myPath As StringDim Sh As ObjectDim Folder As ObjectApplication.ScreenUpdating = FalseOn Error Resume NextSet sfso = CreateObject("Scripting.FileSystemObject")Set Sh = CreateObject("shell.application")Set Folder = Sh.BrowseForFolder(0, "", 0, "")If Not Folder Is Nothing Then myPath = Folder.Items.Item.PathEnd IfApplication.ScreenUpdating = TrueCells(1, 1) = "旧版名称"Cells(1, 2) = "文件类型"Cells(1, 3) = "所在位置"Cells(1, 4) = "新版名称"Call 直接提取文件名(myPath & "\")End SubSub 直接提取文件名(myPath As String) Dim i As Long Dim myTxt As String i = Range("A1048576").End(xlUp).Row myTxt = Dir(myPath, 31) Do While myTxt <> "" On Error Resume Next If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then i = i + 1 Cells(i, 1) = "'" & myTxt If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then Cells(i, 2) = "文件夹" Else Cells(i, 2) = "文件" End If Cells(i, 3) = Left(myPath, Len(myPath) - 1) End If myTxt = Dir LoopEnd SubSub 批量重命名()Dim y_name As StringDim x_name As StringFor i = 2 To Range("A1048576").End(xlUp).Row y_name = Cells(i, 3) & "\" & Cells(i, 1) x_name = Cells(i, 3) & "\" & Cells(i, 4) On Error Resume Next Name y_name As x_nameNextEnd Sub

4、然后回到excel的使用界面，找到视图当中的宏，点击查看宏按钮，如下图所示：

5、接着会弹出使用宏的界面，我们先找到第一个过程，批量获取文件名，并选择执行，如下图所示：

6、执行后，选择好我们要批量命名的文件，如下图的新建文件夹:

7、确定后，在excel即可得到如下的显示，证明我们已经提取成功了文件名：

8、大家看一下，是不是和新建文件夹中的文件名一样，如下图所示：

9、然后在新版名称中，输入我们想变更后的名称，如下图所示：

10、注意，要将文件的扩展名加上，如下图所示：

11、然后删除掉没用的列，如下图所示：

12、同样单击视图，宏当中的查看宏，调出我们的第二个过程，批量重命名，选择执行，如下图所示：

13、好了可以看到我们的文件重命名了，如下图所示：

14、在这里提供给大家，视频的演示：