2023/04/16

Excel / VBA進度條

如果程式執行的時間需要太久

加上執行時的excel有時候看起來像死當

Excel / VBA程式精簡

前一陣子幫家人處理公司的報表

報表是由幾個excel檔案內擷取部分內容、移除重複、組合成新資料等等

依據流程分別為7個sub程序

第一版程式的很多流程是用錄製巨集的方式產生

後來在VBA的寫作技巧與增進效能看到：應該避免不必要的select

而這個通常是在使用錄製巨集產生的程式碼中最常看到的

因為錄製巨集其實就是紀錄使用滑鼠、快捷鍵與excel功能的過程

在試算表的處理流程是無法避免選取點選儲存格，這也就導致程式碼中會有非常多的select

例如：將試算表1的A1:C1複製到試算表的A2:C2

如果使用錄製巨集，產生的程式碼會如下：

Sub 巨集1()

    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy

    Sheets("工作表2").Select
    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

End Sub

而這其實就是滑鼠選取範圍、按右鍵複製、在試算表2的A2貼上

如果以程式控制的方式來撰寫的話，程式碼就會非常精簡，方法也有好幾種

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
Public Sub test()

    Sheets(1).Range("A1:C1").Copy
    
    Sheets(2).Range("A2").PasteSpecial Paste:=xlPasteAll
        
End Sub


Public Sub test2()

    Sheets(1).Range("A1:C1").Copy Destination:=Sheets(2).Range("A3")

    
End Sub

Public Sub test3()

     Sheets(2).Range("A4:C4").Value = Sheets(1).Range("A1:C1").Value
     
End Sub

 

不過這樣就必須搞清楚物件的關係以及可以使用的方法或屬性

Sheets(“工作表2”).Select是選取Sheets物件

Range(“A2”).Select是選取Range物件

Sheets(“工作表2”).Range(“A2”)也是 Range物件

Sheets物件有Paste方法 還有PasteSpecial方法

但是，Range物件只有PasteSpecial方法

精簡程式碼的執行效能，比第一版節省了約25%的時間

不過比較玩味的是我的筆電執行所花的時間是學校桌機的2倍

我的筆電是12代的i5 32Gb Ram

學校桌機是 4代的i7 16Gb Ram

備註

後來發現是因為在筆電執行時，執行的檔案是存放在usb外接硬碟

移到內建的SSD硬碟執行時，確實會比學校的桌機快約30%

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


後來網友再詢問

如何將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