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

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

Post Views: 151

這個是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

 

Tags: