返回列表 上一主題 發帖

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

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

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

不知會否重名,衹演示一下。
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

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

TOP

回復 1# rouber590324

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

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

試試附件吧 !
  1. Option Explicit

  2. Private Sub File_Rename_Click()

  3.     Dim i As Integer
  4.     Dim FolderPath, original_file, rename_file As String
  5.    
  6. '    On Error Resume Next
  7.    
  8.     '選擇來源檔案資料夾
  9.     With Application.FileDialog(msoFileDialogFolderPicker)

  10.         .Title = "選擇檔案來源資料夾"
  11.         .Show
  12.         FolderPath = .SelectedItems(1) & "\"
  13.         Debug.Print FolderPath
  14.    
  15.     End With

  16.     '清空EXCEL
  17.     If Worksheets(1).Range("A2") <> "" Then Worksheets(1).Range("A2:B" & Worksheets(1).Range("A65536").End(xlUp).Row) = ""
  18.    
  19.     '判斷是否有選擇來源資料夾
  20.     If FolderPath <> "" Then
  21.         
  22.         original_file = Dir(FolderPath & "*.*")
  23.         i = 1
  24.         Do Until original_file = ""
  25.             i = i + 1
  26.             Worksheets(1).Cells(i, 1) = original_file
  27.             original_file = Dir
  28.         Loop


  29.         '資料夾不存在則新建
  30.         If Dir(FolderPath & "\Rename", vbDirectory) = "" Then MkDir FolderPath & "\Rename"

  31.         For i = 2 To Worksheets(1).Range("A65536").End(xlUp).Row

  32.             '修改檔名
  33.             If Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 7, 1) = "1" Then
  34.             
  35.                 rename_file = Mid(Worksheets(1).Range("A" & i), 1, 6) & "2" & Mid((Worksheets(1).Range("A" & i)), 8)
  36.                
  37.                 Worksheets(1).Range("B" & i) = rename_file
  38.                
  39.                 Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
  40.                
  41.             ElseIf Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 8, 1) = "製" Then

  42.                 rename_file = Mid(Worksheets(1).Range("A" & i), 1, 7) & Mid(Worksheets(1).Range("A" & i), 9)
  43.                
  44.                 Worksheets(1).Range("B" & i) = rename_file
  45.                
  46.                 Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
  47.                
  48.             End If

  49.         Next

  50.         MsgBox "更名完成"
  51.    
  52.         '開啟結果路徑
  53.         ActiveWorkbook.FollowHyperlink Address:=FolderPath + "\Rename\", NewWindow:=True
  54.    
  55.     End If

  56. End Sub
複製代碼
檔案重新命名.zip (15.62 KB)
用功到世界末日那一天∼∼∼

TOP

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

dear   li_hsien  與  准提部林  大大-
thanks*10000  100%符合需求

TOP

DEAR ALL 大大
1.請教問題如下-
   C:\AAA\下符合改名的檔案改名後放到Rename資料夾內,然後移除C:\AAA\改名成功的檔案,
   而C:\AAA\未成功或非此邏輯性的內的檔案繼續保留。
2.請教如何修改程式.煩不吝賜教  THANKS*10000

TOP

        靜思自在 : 小事不做、大事難成。
返回列表 上一主題