帖子: 463
主題: 127
精華: 0
積分: 595
點名: 20
作業系統: WINDOWS
軟體版本: xp
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2014-9-10
最後登錄: 2019-2-22

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2018-6-22 09:02 | 只看該作者

[發問] 檔案名稱自動變更

DEAR ALL 大大-
1.VBA有無辦法針對 C:\AAA 資料夾內ALL檔案.其名稱符合條件之檔案名稱自動變更
1.1 變更名稱一:
條件: 檔案名稱test1開頭 AND 第7碼=1 時.其第7碼改為2
結果: 例-資料夾內的test1-1-01.txt、test1-1-02.txt和test1-1-03.txt的第七位元1改為2，變成test1-2-01、test1-2-02和test1-2-03。
1.2變更名稱二:
條件:檔案名稱test1開頭 AND 第8碼=製時.其第8碼”製”字樣刪除
結果:例-資料夾內的test1-複製1.txt、test1-複製.txt 2和test1-複製3.txt 內第八碼”製”字樣刪除
2.煩不吝賜教 THANKS

樓主熱帖

羅

Dreamweaver CC 資料庫網頁實例應用：零程式基礎輕鬆製作PHP資料庫網頁

ikboy

中學生 Rank: 2

帖子: 161
主題: 7
精華: 0
積分: 180
點名: 16
作業系統: xp
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2015-8-11
最後登錄: 2019-2-22

2016猴年全勤獎章

2^#

發表於 2018-6-22 10:29 | 只看該作者

不知會否重名，衹演示一下。
Sub zz()
Dim p$, f
p = "Z:\AAA"
f = Dir(p & "\" & "test*")
Do While f <> ""
If Mid(f, 7, 1) = 1 Then Debug.Print Mid(f, 1, 6) & 2 & Mid(f, 8)
If Mid(f, 8, 1) = "製" Then Debug.Print Mid(f, 1, 7) & 2 & Mid(f, 9)
f = Dir
Loop
End Sub

TOP

rouber590324

高中生 Rank: 3 Rank: 3

帖子: 463
主題: 127
精華: 0
積分: 595
點名: 20
作業系統: WINDOWS
軟體版本: xp
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2014-9-10
最後登錄: 2019-2-22

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

3^#

發表於 2018-6-22 11:44 | 只看該作者

DEAR SIR
無法變更名稱.還是謝拉

羅

TOP

li_hsien

中學生 Rank: 2

帖子: 242
主題: 54
精華: 0
積分: 307
點名: 44
作業系統: XP / WIN7
軟體版本: 2003 / 2007
閱讀權限: 20
性別: 男
來自: Tainan
註冊時間: 2013-10-18
最後登錄: 2019-2-23

2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章論壇贊助勳章 2014馬年全勤獎章 2015羊年全勤獎章熱烈參與勳章

4^#

發表於 2018-6-22 14:01 | 只看該作者

回復 1# rouber590324

可以自己指定來源檔案資料夾

最後會把更名後的檔案放到Rename資料夾

試試附件吧 !

Option Explicit
Private Sub File_Rename_Click()
Dim i As Integer
Dim FolderPath, original_file, rename_file As String
' On Error Resume Next
'選擇來源檔案資料夾
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "選擇檔案來源資料夾"
.Show
FolderPath = .SelectedItems(1) & "\"
Debug.Print FolderPath
End With
'清空EXCEL
If Worksheets(1).Range("A2") <> "" Then Worksheets(1).Range("A2:B" & Worksheets(1).Range("A65536").End(xlUp).Row) = ""
'判斷是否有選擇來源資料夾
If FolderPath <> "" Then
original_file = Dir(FolderPath & "*.*")
i = 1
Do Until original_file = ""
i = i + 1
Worksheets(1).Cells(i, 1) = original_file
original_file = Dir
Loop
'資料夾不存在則新建
If Dir(FolderPath & "\Rename", vbDirectory) = "" Then MkDir FolderPath & "\Rename"
For i = 2 To Worksheets(1).Range("A65536").End(xlUp).Row
'修改檔名
If Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 7, 1) = "1" Then
rename_file = Mid(Worksheets(1).Range("A" & i), 1, 6) & "2" & Mid((Worksheets(1).Range("A" & i)), 8)
Worksheets(1).Range("B" & i) = rename_file
Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
ElseIf Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 8, 1) = "製" Then
rename_file = Mid(Worksheets(1).Range("A" & i), 1, 7) & Mid(Worksheets(1).Range("A" & i), 9)
Worksheets(1).Range("B" & i) = rename_file
Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
End If
Next
MsgBox "更名完成"
'開啟結果路徑
ActiveWorkbook.FollowHyperlink Address:=FolderPath + "\Rename\", NewWindow:=True
End If
End Sub

複製代碼

檔案重新命名.zip (15.62 KB)

用功到世界末日那一天～～～

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 1515
主題: 8
精華: 0
積分: 1571
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2019-2-23

5^#

發表於 2018-6-22 17:03 | 只看該作者

Sub TEST()
Dim P$, F$, Nm$
P = "C:\AAA\"
Do
  If F = "" Then F = Dir(P & "test1-*.txt") Else F = Dir()
  If F = "" Then Exit Sub
  Nm = ""
  If Mid(F, 6, 3) = "-1-" Then Nm = Left(F, 6) & 2 & Mid(F, 8)
  If Mid(F, 8, 1) = "製" Then Nm = Left(F, 7) & Mid(F, 9)
  If Nm <> "" Then Name P & F As P & Nm
Loop
End Sub

EXCEL參考資料：
http://blog.xuite.net/smile1000mile/blog

TOP

rouber590324