Excel 请帮助，怎么VBA批量更改文件名

Answer 1

附件 VBA 递归算法 批量提取 & 修改文件名
代码如下：
点击选择文件夹 按钮 选择文件夹， 在C 列输入新文件名后， 点击 重命名按钮 批量重命名

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

Option Explicit
Private Fso As Object, Mypath As String

Sub 选择文件夹()
Dim Fo
Call 清除
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择要批量重命名文件的文件夹"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Mypath = .SelectedItems(1) & "\"
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fo = Fso.getfolder(Mypath)
Call 递归(Fo)
End Sub

Sub 获取文件名(Folder)
Dim Fi, filename As String, r As Integer
For Each Fi In Folder.Files
r = Range("A65536").End(xlUp).Row + 1
filename = Fi.Name
Cells(r, 1) = Folder.Path & "\"
Cells(r, 2) = Fso.getbasename(filename)
Cells(r, 4) = "." & Fso.GetExtensionName(filename)
r = r + 1
Next
End Sub

Sub 递归(Folder)
Dim Fi, Fo
Call 获取文件名(Folder)
If Folder.subFolders.Count > 0 Then
For Each Fo In Folder.subFolders
Call 递归(Fo)
Next
End If
End Sub

Sub 重命名()
Dim i As Integer, r As Integer, Rng As Range
r = Range("A65536").End(xlUp).Row
For Each Rng In Range("C2:C" & r)
If Rng = "" Then MsgBox "请将新文件名填写完整!", 64, "提示": Exit Sub
Next
For i = 2 To Range("A65536").End(xlUp).Row
Name Cells(i, 1) & Cells(i, 2) & Cells(i, 4) As Cells(i, 1) & Cells(i, 3) & Cells(i, 4)
Next
MsgBox "文件名修改完成!", 64, "提示"
Call 清除
End Sub

Sub 清除()
Dim r As Integer
r = Range("A65536").End(xlUp).Row
If r = 1 Then Exit Sub
Range("A2:D" & r).ClearContents
End Sub