- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 1# mark126
試試看- Sub Ex() '複製的檔案,巨集的活頁簿,父層資料夾相同的程式碼
- Dim fs As Object, F As Object, A$, MyPath$
- MyPath = ThisWorkbook.Path '這活頁簿的資料夾名稱
- Set fs = CreateObject("Scripting.FileSystemObject") '提供對電腦檔案系統的存取的物件
- For Each F In fs.GetFolder(MyPath).Files
- '**** asv 這副檔名沒見過 **********
- If InStr(F, "_") And InStr(F, ".asv") Then '檔案名稱中尋找 "_" 副檔名 ".asv"
- A = Mid(F, InStr(F, "_") + 1) '取的"_"之後的字串
- A = Replace(A, ".xls", "") '刪掉副檔名
- A = Replace(A, "-", "\") '替換"-"為"\"
- If fs.FolderExists(MyPath & "\" & Mid(A, 1, 4)) = False Then '找不到[年度]的資料夾
- ChDir MyPath '改變目前的目錄或檔案夾 到 MyPath
- '如複製的檔案目的地與,巨集的活頁簿,父層資料夾不相同,可另設一變數取代 MyPath
- MkDir Mid(A, 1, 4) '建立一個新的目錄或檔案夾。
- End If
- If fs.FolderExists(MyPath & "\" & Mid(A, 1, 7)) = False Then '找不到[年度月份]的資料夾
- ChDir MyPath & "\" & Mid(A, 1, 4)
- MkDir MyPath & "\" & Mid(A, 1, 7)
- End If
- If fs.FolderExists(MyPath & "\" & A) = False Then '找不 [年度月份日期]的資料夾
- ChDir MyPath & "\" & Mid(A, 1, 7)
- MkDir MyPath & "\" & A
- End If
- fs.CopyFile F, MyPath & "\" & A & "\" '複製檔案到 指定的路徑
- End If
- Next
- ChDir MyPath '回到原目錄
- End Sub
|
|
發表於 2011-5-20 08:50
| 