標題: [發問] 資料夾檔案名稱自動變更 [打印本頁]

---

作者: rouber590324    時間: 2018-7-19 13:43     標題: 資料夾檔案名稱自動變更

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

圖一
Sub test2()
Dim i As Integer
Dim FolderPath, original_file, rename_file As String   
    '選擇來源檔案資料夾
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "選擇檔案來源資料夾"
        .Show
        FolderPath = .SelectedItems(1) & "\"
        Debug.Print FolderPath
    End With
    '清空EXCEL
    If Worksheets(2).Range("A2") <> "" Then Worksheets(2).Range("A2:B" & Worksheets(2).Range("A65536").End(xlUp).Row) = ""    '判斷是否有選擇來源資料夾
    If FolderPath <> "" Then
        original_file = Dir(FolderPath & "*.*")
        i = 1
        Do Until original_file = ""
            i = i + 1
            Worksheets(2).Cells(i, 1) = original_file
            original_file = Dir
        Loop
        '資料夾不存在則新建
        If Dir(FolderPath & "\Rename", vbDirectory) = "" Then MkDir FolderPath & "\Rename"
        For i = 2 To Sheet2.Range("A65536").End(xlUp).Row
            '修改第八碼
            If Left(Worksheets(2).Range("A" & i), 12) Like "*" & "-" And Mid(Worksheets(2).Range("A" & i), 13, 3) = Sheet1.Cells(3, 4) Then
                rename_file = Mid(Worksheets(2).Range("A" & i), 1, 12) & Sheet1.Cells(3, 5) & Mid((Worksheets(2).Range("A" & i)), 16)
                Worksheets(2).Range("B" & i) = rename_file
                Call FileSystem.FileCopy(FolderPath & Worksheets(2).Range("A" & i), FolderPath & "\Rename\" & rename_file)
            End If
        Next
        Call CreateObject("WScript.Shell").Popup("更名完成。", 1, "系統訊息")
        '開啟結果路徑
        ActiveWorkbook.FollowHyperlink Address:=FolderPath + "\Rename\", NewWindow:=True
    End If
End Sub

---

作者: rouber590324    時間: 2018-7-24 09:06

DEAR  ALL
已找出 使用  KILL 可殺除文字檔 THANKS

Sub delete_txt_file()
    Dim myName As String
   
    X = Sheet1.[C65536].End(xlUp).Row
    For Y = 2 To X
   
    myName = "C:\AAA\" & Sheet1.Cells(Y, 3) & "" '任意的檔案
    If Len(Dir(myName)) > 0 Then
        Kill myName
    End If
     
    Next
End Sub

Sub DATA()
Sheet1.[C2:C65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
Y = Sheet1.[C65536].End(xlUp).Row
For M = 2 To X
If Not (Sheet1.Cells(M, 2) = "" Or Sheet1.Cells(M, 2) = " ") Then
  Sheet1.Cells(Y + 1, 3) = Sheet1.Cells(M, 1)
    Y = Y + 1
  End If
  Next
End Sub

---

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