Excel vba批量提取文件名 修改文件名!

话不多说，对于批量提取文件名+修改文件名的小软件和小插件，网上也有很多，但是大多数都不安全，今天小编，就和大家来分享一段vba的代码，以及它的使用教程，如果图片无法看清，请点击图片，进行，查看大图的操作，如果觉得经验有用，请记得点击下面的投票按钮。

工具/原料

Vba宏

方法/步骤

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

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

接下来找到thisworkbook的模块，然后将如下的代码，复制粘贴到指定的模块中，如下图所示：

代码：Sub 批量获取文件名()

Cells = ''

Dim sfso

Dim myPath As String

Dim Sh As Object

Dim Folder As Object

Application.ScreenUpdating = False

On Error Resume Next

Set 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.Path

End If

Application.ScreenUpdating = True

Cells(1, 1) = '旧版名称'

Cells(1, 2) = '文件类型'

Cells(1, 3) = '所在位置'

Cells(1, 4) = '新版名称'

Call 直接提取文件名(myPath & '\')

End Sub

Sub 直接提取文件名(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

Loop

End Sub

Sub 批量重命名()

Dim y_name As String

Dim x_name As String

For 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_name

Next

End Sub

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

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

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

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

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

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

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

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

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

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

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

注意事项