Board logo

標題: [發問] 檔案名稱自動變更 [打印本頁]
作者: rouber590324    時間: 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
作者: ikboy    時間: 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
作者: rouber590324    時間: 2018-6-22 11:44

DEAR   SIR
無法變更名稱.還是謝拉
作者: li_hsien    時間: 2018-6-22 14:01

回復 1# rouber590324

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

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

試試附件吧 !
  1. Option Explicit

  3. Private Sub File_Rename_Click()

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

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

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


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

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

  40.             '修改檔名
  41.             If Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 7, 1) = "1" Then
  42.             
  43.                 rename_file = Mid(Worksheets(1).Range("A" & i), 1, 6) & "2" & Mid((Worksheets(1).Range("A" & i)), 8)
  44.                
  45.                 Worksheets(1).Range("B" & i) = rename_file
  46.                
  47.                 Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
  48.                
  49.             ElseIf Left(Worksheets(1).Range("A" & i), 5) = "test1" And Mid(Worksheets(1).Range("A" & i), 8, 1) = "製" Then

  51.                 rename_file = Mid(Worksheets(1).Range("A" & i), 1, 7) & Mid(Worksheets(1).Range("A" & i), 9)
  52.                
  53.                 Worksheets(1).Range("B" & i) = rename_file
  54.                
  55.                 Call FileSystem.FileCopy(FolderPath & Worksheets(1).Range("A" & i), FolderPath & "\Rename\" & rename_file)
  56.                
  57.             End If

  59.         Next

  61.         MsgBox "更名完成"
  62.    
  63.         '開啟結果路徑
  64.         ActiveWorkbook.FollowHyperlink Address:=FolderPath + "\Rename\", NewWindow:=True
  65.    
  66.     End If

  68. End Sub
複製代碼
[attach]28875[/attach]
作者: 准提部林    時間: 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
作者: rouber590324    時間: 2018-6-25 16:57

dear   li_hsien  與  准提部林  大大-
thanks*10000  100%符合需求
作者: rouber590324    時間: 2018-7-17 09:45

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)