如何用VBA快速修改文件名

Sub 批量改名()

  Dim FolderName As String, wbName As String, cValue As Variant

  Dim wbList() As String, wbCount As Integer, i As Integer, str As String, exname As String

  FolderName = "G:\360data\重要数据\桌面\新建文件夹"   '文件夹路径

  '创建文件夹中工作簿列表

  wbCount = 0

  wbName = Dir(FolderName & "\" & "*.xls*")

  While wbName <> ""

    wbCount = wbCount + 1

    ReDim Preserve wbList(1 To wbCount)

    wbList(wbCount) = wbName

    wbName = Dir

  Wend

  If wbCount = 0 Then Exit Sub

  '从每个工作簿中获取数据

  For i = 1 To wbCount

    cValue = GetInfoFromClosedFile(FolderName, wbList(i), "sheet1", "a1")

  exname = Mid(wbList(i), InStr(wbList(i), "."))

  Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & exname

  On Error Resume Next

  Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & i & exname

  Next i

End Sub

'====================从未打开表中获取信息===========================

Private Function GetInfoFromClosedFile(ByVal wbPath As String, _

    wbName As String, wsName As String, cellRef As String) As Variant

  Dim arg As String

  GetInfoFromClosedFile = ""

  If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"

  If Dir(wbPath & "\" & wbName) = "" Then Exit Function

  arg = "'" & wbPath & "[" & wbName & "]" & _

        wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)

  r = 0

  On Error Resume Next

  GetInfoFromClosedFile = ExecuteExcel4Macro(arg)

End Function

附件 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

---