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

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

Post Views: 525

後來網友再詢問

如何將PDF移動到特定的資料夾

其中PDF 跟 資料夾 有對應的名稱關鍵字

我原本是覺得應該在產生PDF跟資料夾的過程中來處理是比較好的方式

不過單純就問題來嘗試處理

算是累積自己的經驗，並且將過程中需要留意的部分記錄下來

整體流程如下：

1.確認移動的資料-#9 -48

由於要知道哪些PDF是要移動的

這次直接用FileDialog() 來選取目標檔案

而為了方便除錯，也將相關的內容都直接寫到試算表

這樣比較好觀察流程，以及確認是否抓到正確的資料

 

2.取得資料夾-#50-74

由於資料夾也是已經存在

所以接下來就是要取得資料夾的資訊

用FileSystemObject 來取得資料夾的完整路徑

 

3.比對關鍵字-#76-127

因為PDF 跟 資料夾都是依據某個報表的欄位組合而成

所以就需要取得這個欄位的資料做為比對

會有2個比對

這邊是利用Application.Search()來比對

原本是想用Application.Match()，但是不知道為什麼都會出錯，後來才發現搞錯用法

第1個比對是有多少個帶有關鍵字的檔案

由於可能不只1個，所以用陣列p1來記錄

如果p1(0)不為0，表示有資料寫入，改變預設值，而且寫入的值會必定是正整數(代表列數)

如果p1(0)為0，表示沒有對應的檔案，將訊息寫入errMsg1

第2個比對是尋找帶有關鍵字的資料夾

由於只會存在1個相對應的資料夾，不然就是沒有，不會有2個對應的資料夾

所以就用1個整數變數p2來記錄

如果p2不為0，同樣表示預設值被改變

如果p2為0，表示沒有對應的資料夾，將訊息寫入errMsg2

 

4.移動檔案-#130-148

接下來依據p1()的數量進行迴圈

這邊要留意的是UBound()取得的值是陣列中最後一筆的序號

假如 p1()有5筆資料，那麼UBound(p1)會是4 (0 ,1 ,2 ,3 ,4)

 

5.釋放記憶體跟刪除比對用的資料-#151-155

6.顯示訊息-#158-166

這邊用了多重if elseif來處理如何呈現errMsg1跟errMsg2

不知道有沒有更好的方式

 

  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
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
 
'
Public Sub 選取PDF移動到特定資料夾6()

    '畫面不更新--不會一直閃動
    Application.ScreenUpdating = False
    
    '關閉警告確認
    Application.DisplayAlerts = False
    
    Dim fd As FileDialog    '宣告一個檔案對話框
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
    
    fd.Filters.Clear    '清除之前的資料
    
    fd.Filters.Add "PDF File", "*.pdf" '設定顯示的副檔名
    fd.Filters.Add "所有檔案", "*.*"
     
   
    '新增試算表
    Sheets.Add After:=Sheets(Sheets.Count)
    
    '修改試算表名稱
    'Sheets(Sheets.Count).Select
    Sheets(Sheets.Count).Name = "選取的檔案資料"
    
    'Sheets("選取的檔案資料").Select
    'Range("A1").Select
    Sheets("選取的檔案資料").Range("A1") = "檔案路徑"
    
    fd.Show '顯示對話框
    
    '檔案數量
    r1 = fd.SelectedItems.Count
    
    '將pdf檔案名稱 寫入Sheets("選取的檔案資料")
    For j = 1 To r1
        '完整檔案路徑
        strFullName = fd.SelectedItems(j)
        'Debug.Print strFullName
               
        '取得檔案名稱
        'LastIndex = UBound(Split(strFullName, "\"))
        
        '寫入試算表
        Sheets("選取的檔案資料").Range("A" & j + 1) = strFullName
        
    Next
    
    '新增試算表
    Sheets.Add After:=Sheets(Sheets.Count)
    
    '修改試算表名稱
    'Sheets(Sheets.Count).Select
    Sheets(Sheets.Count).Name = "讀取資料夾"
    Sheets("讀取資料夾").Range("A1") = "資料夾路徑"
    
    Dim GFN As Object '宣告 GFN 為物件
       
    Set GFN = CreateObject("Scripting.FileSystemObject") '設定 GFN 為Scripting.FileSystemObject物件
    
    dirPath = ThisWorkbook.Path
    
    Set FN = GFN.getfolder(dirPath & "\")
    
    '計數用
    n = 2
    For Each dr In FN.subfolders
         
        Sheets("讀取資料夾").Range("A" & n) = dr
       'Debug.Print dr
       n = n + 1
       
    Next
    
    Dim p1() As Integer  '宣告為陣列
    
    Dim p2 As Integer
    
    Dim errMsg1 As String
    errMsg1 = ""
    
    Dim errMsg2 As String
    errMsg2 = ""
    
    'r2 比對的TW#數量
    For r2 = 2 To Sheets("03報表").Range("B1").End(xlDown).Row
        
        'r3 比對的檔案數量
        Dim m As Integer
        m = 0 '計數用
        ReDim p1(m)
        Dim r3 As Integer
        
        For r3 = 2 To Sheets("選取的檔案資料").Range("A2").End(xlDown).Row
            Var1 = Application.Search(Trim(Sheets("03報表").Range("B" & r2)), Sheets("選取的檔案資料").Range("A" & r3), 1)
            
            If Not IsError(Var1) Then
                
                ReDim Preserve p1(m)
                
                p1(m) = r3
                m = m + 1
            End If
        Next
        
        If p1(0) = 0 Then  '表示沒有資料寫入 仍然是預設值
            errMsg1 = errMsg1 & Trim(Sheets("03報表").Range("B" & r2)) & "缺PDF" & Chr(10)
        End If
        
        'Debug.Print UBound(p1)
        
        'r4 比對的資料夾數量
        p2 = 0
        Dim r4 As Integer
        For r4 = 2 To Sheets("讀取資料夾").Range("A2").End(xlDown).Row
            Var2 = Application.Search(Trim(Sheets("03報表").Range("B" & r2)), Sheets("讀取資料夾").Range("A" & r4), 1)
            
            If Not IsError(Var2) Then
                p2 = r4
            End If
        Next
        Debug.Print p2

        If p2 = 0 Then  '表示沒有資料寫入 仍然是預設值
            errMsg2 = errMsg2 & Trim(Sheets("03報表").Range("B" & r2)) & "缺對應資料夾" & Chr(10)
        End If


        If p1(0) <> 0 And p2 <> 0 Then
        
            For p = 0 To UBound(p1)
                
                filePath = Sheets("選取的檔案資料").Range("A" & p1(p))
                newPath = Sheets("讀取資料夾").Range("A" & p2)
        
                If Dir(newPath, vbDirectory) <> "" Then                            '判斷資料夾是否存在
        
                     Shell "cmd.exe /c move /Y " & Chr(32) & """" & filePath & """" & Chr(32) & """" & newPath & """"
                Else
                     MkDir newPath                                                   '不存在則建立
        
                     Shell "cmd.exe /c move /Y " & Chr(32) & """" & filePath & """" & Chr(32) & """" & newPath & """"     '執行cmd的move  '要注意資料夾路徑內是否有空格
                End If
            
            Next

        End If
    Next
    
    Set FN = Nothing
    Set GFN = Nothing
    For i = Sheets.Count To 4 Step -1
        Sheets(i).Delete
    Next
    
    
    If errMsg1 <> "" Or errMsg2 <> "" Then
        MsgBox errMsg1 & Chr(10) & errMsg2
    ElseIf errMsg1 <> "" And errMsg2 = "" Then
        MsgBox errMsg1
    ElseIf errMsg2 <> "" And errMsg1 = "" Then
        MsgBox errMsg2
    Else
        MsgBox "完成"
    End If
    
    '畫面不更新--不會一直閃動
    Application.ScreenUpdating = True
        
    '關閉警告確認
     Application.DisplayAlerts = True

End Sub
Tags: