- 帖子
- 4
- 主題
- 1
- 精華
- 0
- 積分
- 7
- 點名
- 0
- 作業系統
- windows7
- 軟體版本
- x64
- 閱讀權限
- 10
- 註冊時間
- 2016-1-11
- 最後登錄
- 2021-3-19
|
2#
發表於 2016-1-14 11:00
| 只看該作者
本帖最後由 882138 於 2016-1-14 11:01 編輯
版大你好~我在您部落格有發現有類似的vba,檔案名稱可以更改成我輸入的檔案名稱嗎?而不是尋找全部檔案的- Sub 複製檔案()
- Dim y&, MyPath, uPath, CCPath$, xR As Range, uChk1, uChk2
- Dim Obj, FName1$, FName2$, FL1, FL2, Date1 As Date, Date2 As Date
- y = Cells(Rows.Count, "C").End(xlUp).Row
- If y < 8 Then MsgBox "無檔案明細，請先執行〔載入檔案〕!": Exit Sub
- MyPath = [B1]: If MyPath = "MyPath" Then MyPath = ThisWorkbook.Path
- If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
- uPath = [D1]: If Right(uPath, 1) <> "\" Then uPath = uPath & "\"
- If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到〔目的路徑：" & uPath & "〕 ": Exit Sub
- uChk1 = ActiveSheet.CheckBoxes("選項1").Value
- uChk2 = ActiveSheet.CheckBoxes("選項2").Value
- '-------------------------------------
- Set Obj = CreateObject("Scripting.FileSystemObject")
- Range("E7:E" & y).ClearContents
- For Each xR In Range("C7:C" & y)
- If xR = "" Then
- If uChk1 = xlOn Then
- CCPath = Replace(xR(1, 2) & "\", MyPath, uPath)
- If Dir(CCPath, vbDirectory) = "" Then MkDir CCPath
- xR(1, 3) = "★"
- End If
- GoTo 101
- End If
- '---------------------------
- CCPath = uPath
- If uChk1 = xlOn Then CCPath = Replace(xR(1, 2), MyPath, uPath)
- FName1 = xR(1, 2) & xR(1, 0): FName2 = CCPath & xR(1, 0)
- If uChk2 = xlOn And Dir(FName2) <> "" Then
- Date1 = Obj.GetFile(FName1).DateLastModified '修改日期 (DateCreated '建立日期)
- Date2 = Obj.GetFile(FName2).DateLastModified
- If Date1 <= Date2 Then xR(1, 3) = "...": GoTo 101
- End If
- FileCopy FName1, FName2
- xR(1, 3) = "已複製"
- 101: Next
- Dir ("PP"): Beep
- End Sub
 20140928v01(複製資料夾檔案).rar (23.36 KB)
|
|
發表於 2016-1-15 21:29
| 