Excel / 移動特定檔案到特定資料夾 番外

Excel / 移動特定檔案到特定資料夾 番外

Post Views: 277

後來發現我對於網友的問題是完全沒搞懂方向

其實問題是如何將檔案另存到特定的資料夾

不過也只是將類似的程式碼執行在另存的過程

現在要補充2點

1.檔案路徑內如果有空格

當我把檔案移到別的資料夾時

shell的指令會沒有作用

如果仔細看命令字串的輸出

會發現會是因為檔案路徑內會有空格

如果直接把這個命令字串用命令提示字元(cmd.exe)來執行時

會出現語法錯誤的訊息

要解決這個問題的方式也不難

把檔案路經包裝成字串即可

也就是前後加上”

但是要注意的是這是在VBA程式中輸出 ”

因此除了前後的”表示內容是字串之外

VBA內要輸出1個”，要使用連續2個 ”

所以程式碼必須修改成

    Shell "cmd.exe /c move /Y " & Chr(32) &""""& oldPath & """"& Chr(32) &""""& newPath &""""

 

2.程式碼改成以shell方式處理全部流程

這個方式還用了很多VBA內建函數與陳述式(語法)

先用 “dir /b > 00.txt”產生一個紀錄資料夾內容的00.txt文字檔

然後利用VBA讀取外部檔案的流程

設定開啟檔案使用未使用的檔案編號(FreeFile)

利用Open陳述式讀取檔案

接著用 Line Input陳述式逐行讀取並輸出到變數之中

而逐行讀取的過程是利用EOF 函數配合Do Until EOF() Loop (或者是Do While Not EOF() Loop )進行條件迴圈

再來的流程就都一樣了

最後就是用Kill陳述式刪除00.txt文字檔

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 
Public Sub 移動特定檔案到特定資料夾4()
    Dim xlsx As Variant
    Dim filePath As String
    Dim oldPath As String
    Dim newPath As String
   
    
    filePath = ThisWorkbook.Path
    Debug.Print filePath
    
    'ChDrive "D"
    Debug.Print Split(filePath, "\")(0)        ' D:  , 如果 drive 引數是多字元字串， ChDrive 只會使用第一個字母。

    ChDrive Split(filePath, "\")(0)
    
    ChDir filePath

    Shell "cmd.exe /c dir /b > 00.txt"
    
    Application.Wait (Now + TimeValue("00:00:05")) '等待5秒 不然程式執行太快 還沒寫入檔案就讀取

    Dim myFName As String
    
    myFNo = FreeFile
    
    myFName = Dir(filePath & "\00.txt")
    
    Do While myFName <> ""
        myTxtFile = ThisWorkbook.Path & "\" & myFName
        Open myTxtFile For Input As #myFNo
        
        Do Until EOF(myFNo)
            Line Input #myFNo, myRec
            'Debug.Print myRec
            
            If InStr(myRec, ".") > 0 Then
                xlsx = Split(myRec, ".")   '用.來分割完整檔案名稱
               'Debug.Print xlsx(0)
               'Debug.Print xlsx(1)
                
                If xlsx(1) = "xlsx" Then        '只取副檔名為xlsx的檔案
                   oldPath = filePath & "\" & myRec
                   Debug.Print oldPath
                   newPath = ThisWorkbook.Path & "\" & xlsx(0) & "-資料夾"     '自訂目標資料夾路徑
                   Debug.Print newPath
                   If Dir(newPath, vbDirectory) <> "" Then                            '判斷資料夾是否存在
                      
                      Shell "cmd.exe /c move /Y " & Chr(32) & """" & oldPath & """" & Chr(32) & """" & newPath & """"     '執行cmd的move  '要注意資料夾路徑內是否有空格
                      Debug.Print "cmd.exe /c move /Y " & Chr(32) & """" & oldPath & """" & Chr(32) & """" & newPath & """"
                   Else
                      MkDir newPath                                                   '不存在則建立
                      Shell "cmd.exe /c move /Y " & Chr(32) & """" & oldPath & """" & Chr(32) & """" & newPath & """"     '執行cmd的move  '要注意資料夾路徑內是否有空格
                      Debug.Print "cmd.exe /c move /Y " & Chr(32) & """" & oldPath & """" & Chr(32) & """" & newPath & """"
                   
                   End If
                 
                End If
            End If
        Loop
        
        Close #myFNo
        myFName = ""
    Loop
    
    Kill (ThisWorkbook.Path & "\" & "00.txt")
   
End Sub

 

Tags: ,