標題: [分享] 檔案回到所在地 [打印本頁]

---

作者: mark15jill    時間: 2012-3-12 14:51     標題: 檔案回到所在地

這是可以將檔案 快速放置所要的目錄底下
如果資料很多 手動去搬移的話 會手痠
故以此來做簡單設定後 讓檔案回到該回去的地方

如：
D:\文件\***-文件圖檔.jpg 要放在 ***資料夾底下的 EXCEL檔案
AAA-文件圖檔.jpg 搬移到  AAA\EXCEL\AAA-文件圖檔.JPG

使用方式：
A欄位輸入想要放置的資料夾名稱
且 該跟目錄下放置想搬移的檔案
執行程式碼即可

程式碼如下

1. Sub test()
   
2. 
   
3.     Dim objFs As Object
   
4.     Set objFs = CreateObject("Scripting.FileSystemObject")
   
5.         MkDir "D:\文件\" & Range("a" & wi).Value & "\" & "Excel"             '在A欄位資料夾內創立 EXCEL資料夾
   
6.         MkDir "D:\文件\" & Range("a" & wi).Value & "\" & "圖片存放區"   '在A欄位資料夾內創立 圖片存放區資料夾
   
7. 
   
8.     Columns("H:H").Select
   
9.     Selection.NumberFormatLocal = "@" '文字型態
   
10.     Columns("t:t").Select
    
11.     Selection.NumberFormatLocal = "@" '文字型態
    
12. 
    
13. 
    
14. Range("h1").Value = Right(Range("e1").Value, 4)
    
15.     For xi = 1 To 999
    
16.         If Range("a" & xi).Value <> "" Then
    
17.             xy = xi
    
18.         End If
    
19.     Next
    
20. For xt = 1 To xy
    
21.         xo = Range("j" & xt).Value
    
22.                 Columns("H:H").Select
    
23.                 Selection.NumberFormatLocal = "@"
    
24.                 Range("h" & xt).Value = Right(Range("e" & xt).Value, 4)
    
25. 
    
26.                
    
27.             For xuo = 1 To 999
    
28.                 If Dir("D:\文件\" & Range("e" & xuo).Value & "-文件圖檔.jpg") <> "" Then
    
29.                     objFs.moveFile "D:\文件\" & Range("e" & xuo).Value & "-文件圖檔.jpg", "D:\文件\" & Range("a" & xuo).Value & "\excel\"
    
30.                 End If
    
31.             Next xuo
    
32. 
    
33. 
    
34.            For xww = 1 To 999
    
35.                 If Dir("D:\文件\" & Range("a" & xt).Value & Range("h" & xww).Value & ".jpg") <> "" Then
    
36. 
    
37.                        objFs.moveFile "D:\文件\" & Range("a" & xt).Value & Range("h" & xww).Value & ".jpg", "D:\文件\" & Range("a" & xt).Value & "\圖片存放\"
    
38.                 End If
    
39.             Next xww
    
40. Next xt
    
41. End Sub

複製代碼

---

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