返回列表 上一主題 發帖

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

li_hsien

帖子
248 
主題
55 
精華
0 
積分
314 
點名
94  
作業系統
XP / WIN7 
軟體版本
2003 / 2007 
閱讀權限
20 
性別
男 
來自
Tainan 
註冊時間
2013-10-18 
最後登錄
2024-5-10 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇贊助勳章2014馬年全勤獎章2015羊年全勤獎章熱烈參與勳章
1# 跳轉到 »
發表於 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
複製代碼
檔案重新命名.zip (15.62 KB)
用功到世界末日那一天∼∼∼

TOP

        靜思自在 : 人的心地是一畦田，土地沒有播下好種子，也長不出好的果實。 -
返回列表 上一主題