標題: [發問] 請問excel可以將想要檔案全都移動複製到固定資料夾內嗎? [打印本頁]

---

作者: 882138    時間: 2016-1-13 13:19     標題: 請問excel可以將想要檔案全都移動複製到固定資料夾內嗎?

因為圖檔非常多,所以想利用excel把pdf檔都抓出來,最後再用pdf合併成一個檔案,希望有大大可以解答,感謝^^
[attach]23097[/attach]

---

作者: 882138    時間: 2016-1-14 11:00

本帖最後由 882138 於 2016-1-14 11:01 編輯

版大你好~我在您部落格有發現有類似的vba,檔案名稱可以更改成我輸入的檔案名稱嗎?而不是尋找全部檔案的

1. Sub 複製檔案()
   
2. Dim y&, MyPath, uPath, CCPath$, xR As Range, uChk1, uChk2
   
3. Dim Obj, FName1$, FName2$, FL1, FL2, Date1 As Date, Date2 As Date
   
4. y = Cells(Rows.Count, "C").End(xlUp).Row
   
5. If y < 8 Then MsgBox "無檔案明細，請先執行〔載入檔案〕!": Exit Sub
   
6. MyPath = [B1]: If MyPath = "MyPath" Then MyPath = ThisWorkbook.Path
   
7. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
   
8. uPath = [D1]: If Right(uPath, 1) <> "\" Then uPath = uPath & "\"
   
9. If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到〔目的路徑：" & uPath & "〕　": Exit Sub
   
10. uChk1 = ActiveSheet.CheckBoxes("選項1").Value
    
11. uChk2 = ActiveSheet.CheckBoxes("選項2").Value
    
12. '-------------------------------------
    
13. Set Obj = CreateObject("Scripting.FileSystemObject")
    
14. Range("E7:E" & y).ClearContents
    
15. For Each xR In Range("C7:C" & y)
    
16.     If xR = "" Then
    
17.        If uChk1 = xlOn Then
    
18.           CCPath = Replace(xR(1, 2) & "\", MyPath, uPath)
    
19.           If Dir(CCPath, vbDirectory) = "" Then MkDir CCPath
    
20.           xR(1, 3) = "★"
    
21.        End If
    
22.        GoTo 101
    
23.     End If
    
24.     '---------------------------
    
25.     CCPath = uPath
    
26.     If uChk1 = xlOn Then CCPath = Replace(xR(1, 2), MyPath, uPath)
    
27.     FName1 = xR(1, 2) & xR(1, 0):   FName2 = CCPath & xR(1, 0)
    
28.     If uChk2 = xlOn And Dir(FName2) <> "" Then
    
29.        Date1 = Obj.GetFile(FName1).DateLastModified '修改日期 (DateCreated '建立日期)
    
30.        Date2 = Obj.GetFile(FName2).DateLastModified
    
31.        If Date1 <= Date2 Then xR(1, 3) = "...": GoTo 101
    
32.     End If
    
33.     FileCopy FName1, FName2
    
34.     xR(1, 3) = "已複製"
    
35. 101: Next
    
36. Dir ("PP"): Beep
    
37. End Sub

複製代碼

[attach]23110[/attach]

---

作者: 准提部林    時間: 2016-1-15 21:29

Sub TEST()
Dim xR As Range, FS, xFile$
Set FS = CreateObject("Scripting.FileSystemObject")
For Each xR In Range([A1], [A65536].End(xlUp))
　　If xR <> "" Then
　　　　xFile = "D:\123\" & xR & "*.pdf"
　　　　If Dir(xFile) <> "" Then FS.CopyFile xFile, "D:\456\"
　　End If
Next
End Sub

---

作者: 882138    時間: 2016-1-19 13:12

回復 3# 准提部林

謝謝版大無私分享,版大太神了!!

---

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