Excel / VBA進度條

Excel / VBA進度條

Post Views: 470

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

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

如果有進度條的話，應該可以避免這種誤會

 

32位元的excel可以用mscomctl.ocx控制項的ProgressBar來製作

但是現在大多是用64位元的excel，所以這種方式的應用性不高了

不過可以改用表單的Label標籤的功能來產生相似的功能

1.首先新增一個表單，並加入Label

可以修改預設的表單與Label名稱

方便之後的程式碼使用

這裡是將表單命名為labelBar、Label命名為PB，width=430

這些都是在「屬性視窗」修改

2.撰寫程式碼

思路有2種

第1種是利用表單的Activate()事件

把要執行的程序寫在這邊

之後只要啟動表單即可

例如：

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
 
Sub UserForm_Activate()
    '狀態列歸零
    PB.Width = 0
    Call 刪除舊工作表
    '1.工作表名稱範圍
    r = Sheets(1).Range("A2").End(xlDown).Row
    For i = 2 To r
        '2.取得類股名稱
        x = Sheets(1).Cells(i, "A")
        y = Sheets(1).Cells(i, "B")
        '3.新增工作表並重新命名
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = x
        '下載資料
        Call 股市下載(y)
        PB.Width = (i - 1) * (400 / (r - 1))
        home.Repaint
    Next
    Sheets(1).Select
    home.Hide
End Sub

 

第2種是寫在執行程序中

這種方式要留意的是必須允許其他程序能夠同時執行

表單.show 必須加上0，表示vbModeless

不然正常的情況下執行表單，表單會在最上層，而且無法控制試算表與其他程序

表單.show 0

以下是土炮的程式碼

 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
 
Sub test()
 labelBar.Show 0
 
 labelBar.PB.Width = 0
 
 labelBar.Caption = "t1"
 Call t1
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t2"
 Call t2
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t3"
 Call t3
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t4"
 Call t4
 Application.Wait (Now + TimeValue("0:00:03"))
 
 labelBar.Caption = "t5"
 Call t5
 Application.Wait (Now + TimeValue("0:00:03"))
 
 Unload labelBar
  
 MsgBox "執行完畢"

End Sub

Sub t1()

    labelBar.PB.Width = 430 * 0.2
    labelBar.Repaint
    
End Sub

Sub t2()

    labelBar.PB.Width = 430 * 0.4
    labelBar.Repaint
    
End Sub

Sub t3()

    labelBar.PB.Width = 430 * 0.6
    labelBar.Repaint
    
End Sub

Sub t4()

    labelBar.PB.Width = 430 * 0.8
    labelBar.Repaint
    
End Sub

Sub t5()

    labelBar.PB.Width = 430 * 1
    labelBar.Repaint
    
End Sub

 

備註：後來看之前的VBA練習，其實還有第3種方式：在表單內執行程序

也就是在表單設計功能選項或按鈕來執行程序

例如：

Sub 批次篩選(清單 As String, 欄位 As Integer)會接受表單傳來的參數

來處理篩選的流程，並且修改進度條的參數

 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
 
Sub 批次篩選(清單 As String, 欄位 As Integer)
    Call 批次刪除
    Application.ScreenUpdating = False
    r = Sheets("清單").Range(清單 & "2").End(xlDown).Row
    For i = 2 To r
        X = Sheets("清單").Cells(i, 清單)
        
        '1.游標放B1
        Range("B1").Select
        '2.篩選
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$L$2500").AutoFilter Field:=欄位, Criteria1:=X
        '3.複製
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        
        '4.新增工作表
        Sheets.Add After:=Sheets(Sheets.Count)
        '命名
        Sheets(Sheets.Count).Name = X
        
        '5.貼上
        Range("A1").Select
        ActiveSheet.Paste
        
        '6.自動調整欄寬
        Selection.Columns.AutoFit
        
        Range("A1").Select
        
        '7.切回原工作表
        Sheets(1).Select
        
        '8.取消篩選
        Selection.AutoFilter
        
        '9.切回到A1
        Range("A1").Select
        home.PB.Width = (i - 1) * 400 / (r - 1)
        home.lb01.Caption = "執行率" & Math.Round((i - 1) / (r - 1), 2) * 100 & "%"
        home.Repaint
    
    Application.StatusBar = i & "筆"
    Next
    Application.ScreenUpdating = True
End Sub

 

表單的程式碼：

表單開啟時的初始設定：將labe PB寬度設定為0，加入下拉式選單選項

按鈕CommandButton1被點選時，依據選單選項傳遞參數到 批次篩選()

而進度條也就會隨著修改

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
 
Sub CommandButton1_Click() 
	If cd01.Text = "業務" Then 
		Call 批次篩選("A", 3) 
	ElseIf cd01.Text = "產業別" Then 
		Call 批次篩選("B", 4) 
	ElseIf cd01.Text = "產品" Then 
		Call 批次篩選("C", 5) 
	ElseIf cd01.Text = "客戶名稱" Then 
		Call 批次篩選("D", 12) 
	End If 
End Sub

Sub UserForm_Initialize() 
	PB.Width = 0 
	cd01.AddItem "請選擇篩選類別" 
	cd01.AddItem "業務" 
	cd01.AddItem "產業別" 
	cd01.AddItem "產品" 
	cd01.AddItem "客戶名稱" 
End Sub

 

這樣就可以避免表單啟動時，其他程序無法執行的問題

Tags: