Excel / 使用VBA批次修改檔案名稱

這個是Line社團的提問

讓我想起之前"彰化一整天"有個類似的VBA程式

不過他的程式是處理在同一個資料夾內的檔案

我嘗試修改成可以批次重新命名不同資料夾的檔案名稱

---

操作介面，主要需要三個欄位

A欄是透過FileDialog取得的檔案完整路徑

B欄是取得A欄資料之後，取得的檔案名稱，方便用來設定新的檔案名稱

C欄是紀錄程式執行的結果，如果有問題也會在這裡寫出錯誤訊息

第一個按鈕執行cmdClear()

刪除A欄至B欄的內容

1
2
3
4
5

Public Sub cmdClear()

Sheets(1).Range("A2:C" & Excel.Rows.Count).Clear '將舊的A-C欄資料清除

End Sub

 

第二個按鈕執行cmdSelectFile()

取得要修改的檔案完整路徑

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

Public Sub cmdSelectFile()
Dim fd As FileDialog '宣告一個檔案對話框

Set fd = Application.FileDialog(msoFileDialogFilePicker) '設定選取檔案功能

fd.Filters.Clear '清除之前的資料

fd.InitialFileName = ActiveWorkbook.Path '設定預設目錄

fd.AllowMultiSelect = True

' fd.Filters.Add "Excel File", "*.xls*" '設定顯示的副檔名
' fd.Filters.Add "Word File", "*.txt"
' fd.Filters.Add "Word File", "*.csv"
fd.Filters.Add "所有檔案", "*.*"

fd.Show '顯示對話框

Dim startx As Integer
If Range("A1").End(xlDown).Row = 1048576 Then
startx = 0 '已選取檔案數
Else
startx = Range("A1").End(xlDown).Row - 1
End If
Dim i As Integer
Dim n As Integer
Dim strFullName As String
Dim fileName As String

For i = 1 To fd.SelectedItems.Count
strFullName = fd.SelectedItems(i)
n = rinstr(strFullName, "\")
fileName = Mid(strFullName, n + 1)
Sheets(1).Cells(i + 1 + startx, 1) = strFullName
Sheets(1).Cells(i + 1 + startx, 2) = fileName

Next
End Sub

 

第三個按鈕執行fileRename()

程式架構修改自[VBA] EXCEL 批次修改指定檔名

這個程式跟「彰化一整天」的類似，都是處理同一個資料夾內的檔案

我把流程改為可以批次重新命名不同資料夾內的檔案

程式利用FileSystemObject來處理檔案

如果使用早期繫結建立FileSystemObject，要先在 工具/設定引用項目 勾選「Microsoft Scripting Runtime」

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

Sub fileRename()
Dim myRng1 As Range
Dim myRng2 As Range
Dim myRng As Range
Dim OldfilePath As String
Dim NewfilePath As String
Dim i As Integer
Dim OldfileDir As String
Dim NewfileDir As String
Dim OldName As String
Dim NewName As String
Dim n1 As Integer
Dim n2 As Integer
'=====================================
Dim myFso As Scripting.FileSystemObject ' 建立FileSystemObject
Set myFso = New Scripting.FileSystemObject
'=====================================
Dim Wok As Worksheet
Set Wok = Worksheets("重新命名列表")

'=====================================
Set myRng1 = Cells(Rows.Count, 1) '取得最下方的儲存格
With myRng1
If Len(.PrefixCharacter & .Formula) > 0 Then
Set myRng2 = myRng1 '若最下方的儲存格符合條件時
Else
With .End(xlUp)
If Len(.PrefixCharacter & .Formula) > 0 Then
Set myRng2 = .Cells(1)
End If
End With
End If
End With
If myRng2 Is Nothing Or myRng2.Value = Range("A1").Value Then MsgBox "沒有輸入任何資料": Exit Sub
Set myRng = Range(myRng2.Address)
'===================================== 取代開始
For i = 2 To myRng.Row
Wok.Cells(i, 3) = ""
OldfilePath = Wok.Cells(i, 1).Value '檔案路徑
n1 = rinstr(OldfilePath, "\")
OldfileDir = Mid(OldfilePath, 1, n1) '資料夾路徑
OldName = Mid(OldfilePath, n1 + 1)

' NewfilePath = Wok.Cells(i, 2) '檔案路徑
' n2 = rinstr(NewfilePath, "\")
' NewfileDir = Mid(NewfilePath, 1, n2) '資料夾路徑
NewName = Wok.Cells(i, 2).Value
NewfilePath = OldfileDir & NewName

If Right(OldfileDir, 1) <> "\" Then OldfileDir = OldfileDir & "\"
' If Right(NewfileDir, 1) <> "\" Then NewfileDir = NewfileDir & "\"

If OldfilePath <> "" And NewName <> OldName And NewName <> "" Then
If myFso.FileExists(FileSpec:=OldfilePath) Then
Name OldfilePath As NewfilePath ' 更改檔名
Wok.Cells(i, 3).Value = "完成!!"
Else
Wok.Cells(i, 3).Value = "檔案不存在"
End If
ElseIf NewName = OldName Then
If NewName = "" And OldName = "" Then
Wok.Cells(i, 3).Value = "請確認資料"
Else
Wok.Cells(i, 3).Value = "名稱一樣"
End If
ElseIf NewName = "" Then
Wok.Cells(i, 3).Value = "請確認修改檔名"
ElseIf OldfilePath = "" Then
Wok.Cells(i, 3).Value = "請確認目標檔案"
End If
Next
'=====================================
Set myRng1 = Nothing '物件的釋放
Set myRng2 = Nothing
Set myFso = Nothing
End Sub