針對查詢「autofilter」依關聯性排序顯示文章。依日期排序 顯示所有文章
針對查詢「autofilter」依關聯性排序顯示文章。依日期排序 顯示所有文章

2023年11月15日 星期三

初學者的VBA資料分析 CLASS 3:基本資料分析任務 開始 3.1 數據篩選和排序

 CLASS 3:基本資料分析任務 開始

 3.1 數據篩選和排序

     使用VBA篩選和排序Excel資料。

3.2 計算和公式

     使用VBA錄製巨集和編輯Excel公式。

3.3 簡單的資料視覺化

     創建基本的圖表和圖形。

二、講解:

 3.1 資料篩選和排序

先來看看資料篩選,篩選有常使用篩選功能的每個excel大神,一定都很清楚可以區分為進階篩選跟篩選,都很好用,但我們來用用vba來強化這項應用


先來看篩選,也就是autofilter,其實小編也發過類似的文,可以參考看看

從基本的autofilter 這個物件的"方法",來玩玩吧

先來看看autofilter是啥?可以參圖1,其餘EXCEL怎操作不解釋了,偷個懶。

圖1.篩選圖示
小編引用MSDN,MSDN講了好多阿,小編來個入門版教學一下:
快速錄了一個錄製版巨集,如下:


圖2.資料樣貌


Sub 巨集1()

    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$E$13").AutoFilter Field:=3, Criteria1:="=1", _
        Operator:=xlAnd
    ActiveSheet.ShowAllData
    ActiveSheet.Range("$A$1:$E$13").AutoFilter Field:=5, Criteria1:="=1", _
        Operator:=xlAnd
    ActiveSheet.ShowAllData
    
End Sub

節錄一段code來看看   
針對工作表中a1:a13 範圍:ActiveSheet.Range("$A$1:$E$13")
篩選第3行:.AutoFilter Field:=3, 

圖3.資料行別對照

篩選條件為1:Criteria1:="=1", 
篩選方式為:Operator:=xlAnd

這樣執行巨集1結果如下圖:
圖4.巨集1運作
圖4說明:先跑b行,然後復原在跑d行。

取消篩選:ActiveSheet.ShowAllData 
執行次行命令後,即恢復篩選前狀態。

以上是篩選的基本入門操作,至於更多的用法,可以參考小編的其他文。

接著來看排序功能,排序會使用到sort這個方法,老樣子先來個msdn一下
到這不免很多看官會說,啥都msdn,那你整理文章做啥,小編是想,你要先知道官方有技術指導,看無官方版不打緊,來看看小編的入門篇之後,普出一點道理之後,再回去看官方的,或許能幫到一點點忙;畢竟講語法實在是太讓人想滑鼠點上一頁閃了。畢竟網路上也很多人寫類似的,選你好看好懂得,up to you。

言歸正傳,啥是排序,排序就是基本排序資料的一個功能,可以參圖5,其餘EXCEL怎操作不解釋了,偷個懶。
圖5.排序按鈕

小編來個sort入門版教學一下,快速錄了一個錄製版巨集,如下:

錄得滿多的,a行的排序,a、b雙行的排序等

某一關鍵參數:大到小,小到大列舉

Sub 巨集2()
'a行的排序 小到大
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("B2:B13"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("工作表1").Sort
        .SetRange Range("A1:E13")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'a行的排序 大到小
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("B2:B13"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("工作表1").Sort
        .SetRange Range("A1:E13")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'a行與b行接排序 大到小
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("B2:B13"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("C2:C13"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("工作表1").Sort
        .SetRange Range("A1:E13")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

小編先說哇,錄了好長一串,來慢慢看過來
用錄製取得的CODE明顯好像跟上面提的SORT MSND內容不一樣

小編在補一下應外一塊MSDN,對照範例與小編錄製的內容
小編:
'a行的排序 小到大

    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("B2:B13"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("工作表1").Sort
        .SetRange Range("A1:E13")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

微軟MSDN:
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
 Key:=Range("Table1[[#All],[Column1]]"), _
 SortOn:=xlSortOnValues, _
 Order:=xlAscending, _
 DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
 .Header = xlYes
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
End With

其實除了工作表與儲存格範圍外,範例跟錄製的內容真的長的很像ㄝ,但還是有不同,先回到主軸上排序上
回想一下,透過滑鼠點選操作排序時,有幾個必要設定的地方,分別是要排序那些儲存格,根據那些儲存格當依據做排序,先來看當使用Sort.SortFields時,主要必設定的部分:
清除篩選: ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
增加範圍:  ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add
設定排序條件範圍:Key:=Range("B2:B13"), _
設定排序條件範圍參數:SortOn:=xlSortOnValues, Order:=xlAscending,DataOption:=xlSortNormal

相關參數就不多再談了,先拉回到排序sort的重點整理一下:
1.資料範圍
2.資料排序依據
3.排序方法選擇(大到小......)
小編想,可能需要寫一篇專文了,呵呵,這邊還是以引入觀念為主。
不然就都泡在程式碼裏頭,引用當兵學長的話,"歐,強哥,這很難吞下的下去說"。

小編遇到難免會多補充很多,接下小編端上速成版排序做參考:
3原則
1.資料範圍
2.資料排序依據
3.排序方法選擇(大到小......)

單一排序依據:
activesheet.Range(資料範圍).Sort _
Key1:=activesheet.Range(資料範圍排序依據行別),  _
Order1:=資料排序方式, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod  :=xlStroke, _
DataOption1:=xlSortNormal

2組排序依據:
activesheet.Range(資料範圍).Sort _
Key1:=activesheet.Range(資料範圍排序依據行別1),  _
Order1:=資料排序方式1, Header:=xlYes, _
Key2:=activesheet.Range(資料範圍排序依據行別2),  _
Order2:=資料排序方式2, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod  :=xlStroke, _
DataOption1:=xlSortNormal

對,就是這樣簡單!!!! 怎我前面一堆廢話 (>__<)

排序 演練一下:

Private Sub CommandButton2_Click()

ActiveSheet.Range("b1:e30").Sort _
Key1:=ActiveSheet.Range("b1"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke, _
DataOption1:=xlSortNormal

ActiveSheet.Range("b1:e30").Sort _
Key1:=ActiveSheet.Range("b1"), _
Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke, _
DataOption1:=xlSortNormal

End Sub



Private Sub CommandButton3_Click()

ActiveSheet.Range("b1:e30").Sort _
Key1:=ActiveSheet.Range("b1"), _
Order1:=xlAscending, Header:=xlYes, _
Key2:=ActiveSheet.Range("c1"), _
Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke, _
DataOption1:=xlSortNormal

ActiveSheet.Range("b1:e30").Sort _
Key1:=ActiveSheet.Range("b1"), _
Order1:=xlDescending, Header:=xlYes, _
Key2:=ActiveSheet.Range("c1"), _
Order2:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke, _
DataOption1:=xlSortNormal

End Sub










2023年10月4日 星期三

VBA:使用AutoFilter 批次篩選多筆資料,非多項目歐

 autofilter 滿足多筆資料篩選,如果你是excel使用者,還不知道怎操作vba,那真是可惜

這好用功能配合vba,簡直太神了;當然這時候可能有人說,我可以樞紐阿,阿樞紐分析不用點選嗎?QQ

簡單對比操作一下:


這段功能阿,可以透過錄製方式直接搞定,所以小編不想花太多時間解釋怎樣錄製,而是想表示,怎樣整理這樣的功能呢!!!

 Sheets("工作表1").Range("a1:i" & XX1).AutoFilter Field:=1, Criteria1:=ARRAY, Operator:=xlFilterValues

 Sheets("工作表1").Range("a1:i" & XX1):需要篩選的資料區域
AutoFilter 使用這個方法
Field:設定要篩選的行別
Criteria1:篩選條件,ARRAY非程式碼,ARRAY是簡稱用,在這主要表達要放一個陣列
Operator:篩選作業執行方式

EX:
 Sheets("工作表1").Range("a1:i" & XX1).AutoFilter Field:=1, Criteria1:=ARRAY("1101","1102"), Operator:=xlFilterValues

篩選後剩下1101、1102

下次來看看怎樣篩選:
VBA:使用AutoFilter 批次篩選多筆資料與多項目

2023年8月28日 星期一

錯誤2015 error 2015 application.countif +AutoFilter 溫故知新

 今天小編透過autofilter與application.countif 做資料整理,

怎就application.countif 跑不出來,實在很懊惱ㄝ

明明是很常用的函數說。

抱怨解決不了問題。

先來溫故知新一下:

AutoFilter 篩選日期區間怎做:

在資料區間n1:m1531範圍內透過日期區間做篩選,所以會有兩個Criteria要設定,分別為Criteria1與Criteria2,因為兩個條件都要滿足,所以Operator要加上xlAnd,如此如此這般這般。msdn

ActiveSheet.Range("$N$1:$N$1531").AutoFilter Field:=1, Criteria1:= _

        ">=" & date_test, Operator:=xlAnd, Criteria2:="<=" & end_day

好!!那篩選完成後,要統計一下資料,僅計算篩選後的儲存格範圍(msdn)

這功能稱為XlCellType,很好用,要放在口袋內放好。

透過設置set p_data,僅取用篩選後的儲存格 

 Set p_data = ActiveSheet.Range("m2:m1531").SpecialCells(xlCellTypeVisible)

接下來是統計次數資料的countif函數。

講到這,小編countif 使用到底錯那了?

          Set p_data = ActiveSheet.Range("m2:m1531").SpecialCells(xlCellTypeVisible)

         Set p_data = ActiveSheet.Range("m1:m1531").SpecialCells(xlCellTypeVisible)

錯在設置時把標題放入,所以countif 跑出"錯誤2015"

下次記得別把標題放進範圍內 xd

countif使用,直接調用Application即可

p1 = Application.CountIf(p_data , ">0")

p2 = Application.CountIf(p_data , "<=0")

幫忙計算出大於跟小於等於0的次數,太棒了。

另外篩選範圍也要跟countif計算範圍相同,不然也會跳出"錯誤2015"

ActiveSheet.Range("$N$1:$N$1530").AutoFilter Field:=1, Criteria1:= _

        ">=" & date_test, Operator:=xlAnd, Criteria2:="<=" & end_day

 Set p_data = ActiveSheet.Range("m2:m1531").SpecialCells(xlCellTypeVisible)

反紅為錯誤示範。






2023年8月2日 星期三

sumproduct  v.s autofilter 分析資料時間整理

之前整理過一篇透過sumproduct整理資料的文章,但excel還是有很多好用的工具可以用
但這篇小編不想花太多時間介紹有那些工具。

小編這次先測試不同工具之間的效率差多少。

sumproduct v.s autofilter

資料筆數:約20萬筆
測試要點:不同方法效率比較


sumproduct 運行181秒
autofilter 運行31秒

p.s每個人運行時間應該有差異,但autofilter應該還是比sumproduct快拉。

下一篇來寫寫autofilter教學

 

2025年6月19日 星期四

vba autofilter v.s mysql 查詢與計算語法 比較

 autofilter :是針對既有資料,設定一定程度的條件,此條件可以是單一也可以是多條件後,開始做篩選,但前提是excel本身已準備好資料讓你篩選。

mysql 語法:可以執行最基本的條件查詢、計算後,顯示結果。

比較不同平台,一個是excel,一個是mysql。

其實小編相信很多網路大神一定會說,這還需要比較?

小編想要整理出,不同資料筆數之間差異,當然學習歷程時間也是一個差異,畢竟學excel跟學sql還是有點本質上的不同,但有ai後,似乎有打雞血的up點。

所以小編,以自己常在整理的資料,來做簡單比較:

目前小編每個月會根據台灣上市櫃公司,做產業別資料整理,隨著時間拉長,資料整理期間自然越來越長,就選這個常在整理的資料來比較吧!!

條件:

查詢110/01~110/12的合計15個產業別各月產業別營收

結果:

EXCEL,133.5秒

SQL,76.46秒;

小編進一步改成直接查詢105/01~114/05拉大13倍查詢範圍,變成71.203,決定在測一次70.698。

比較後,小編呵呵笑了,原來比較後,也確認了是EXCEL寫資料表時間最耗時,

對SQL來說擴大13倍查詢根本不是問題。

小編就不測試EXCEL擴大13倍後,需要花費多少時間了。

也有另外一個可能,就是小編寫的AUTOFILTER 效率太差,應該拿去效率最好的方法去PK阿。

QQ。

方法有很多,熟悉有幾個,能學好多個,答案靠己尋。


附上小編自己的VBA:(很差,參考)

SUB C1' SQL

 shell "powercfg.exe setactive 8c5e7fda-e8bf-4a96-9a85-a6e23a8c635c " '高效能 

On Error GoTo LINE1

ActiveSheet.Range("A:G").Clear    

S1 = ActiveSheet.Range("aa2000").End(xlUp).Row

data = INCOME_SQL_SUM_catrgory("105/01", "114/05")

For i = LBound(data, 1) To UBound(data, 1)

    For j = LBound(data, 2) To UBound(data, 2)

        If IsNull(data(i, j)) Then data(i, j) = "" ' 替換Null為空字串

        If IsNumeric(data(i, j)) Then data(i, j) = CStr(data(i, j)) ' 統一轉文字型態

    Next j

Next i

ActiveSheet.Range("A1").Resize(UBound(data, 2), UBound(data, 1) + 1) = WorksheetFunction.Transpose(data)

For i = 1 To UBound(data, 2) + 1 Step 1             

              If ActiveSheet.Range("C" & i + 1) <> "" And ActiveSheet.Range("C" & i + 1) <> "" And _

              ActiveSheet.Range("C" & i + 1) <> 0 And ActiveSheet.Range("C" & i + 1) <> 0 Then            

            ActiveSheet.Range("F" & i + 1).Value = (val(ActiveSheet.Range("C" & i + 1).Value) - _

            val(ActiveSheet.Range("D" & i + 1).Value)) / val(ActiveSheet.Range("D" & i + 1).Value)                 End If

Next    

TOPIC = Array("產業別", "月份", "當月營收", "去年當月營收", "新高家數", "年增減(%)")

ActiveSheet.Range("A1:F1").Insert

ActiveSheet.Range("A1:F1") = TOPIC          

s3 = ActiveSheet.Range("B1000000").End(xlUp).Row   

     ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(s3, 7 + 2)).Sort key1:=ActiveSheet.Range("a" & ":" & "a"), order1:=xlAscending, Header:=xlYes, _

        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlStroke, DataOption1:=xlSortNormal                         

                           Beep                           

                           Beep                           

                           Beep                           

                             MsgBox Timer - T

                            Exit Sub

LINE1:

MsgBox "ERROR"                            

                            Resume

END SUB


SUB C2 'AUTOFILTER

 Application.ScreenUpdating = False

  Application.DisplayStatusBar = False

  Application.Calculation = xlCalculationManual

  Application.EnableEvents = False

  ' Note: this is a sheet-level setting.

 ' ActiveSheet.DisplayPageBreaks = False

SOURCE = Excel.ActiveWorkbook.Name

 Shell "powercfg.exe setactive 8c5e7fda-e8bf-4a96-9a85-a6e23a8c635c " '高效能

 On Error GoTo LINE1

Sheets("產業別").Range("A:E").Clear    

S1 = Sheets("產業別").Range("aa2000").End(xlUp).Row

 list_data = Sheets("產業別").Range("aa1:aa" & S1) 

 list_data = 移除重複(list_data) 

 S1 = Sheets("產業別").Range("z2000").End(xlUp).Row 

  list_data2 = Sheets("產業別").Range("z1:z" & S1) 

 list_data2 = 移除重複(list_data2) 

  Sheets("產業別").Range("a:e").Clear

ADD = 2

TOPIC = Array("產業別", "月份", "當月營收", "去年當月營收", "年增減(%)")

Sheets("產業別").Range("A1:E1") = TOPIC

 SOURCE = Excel.ActiveWorkbook.Name

For j = LBound(list_data2) To UBound(list_data2) Step 1 '(J) <> ""

            Sheets("月營收").Activate            

            'XX1 = Application.CountA(Sheets("月營收").Range("A:a")) '.End(xlUp).Row     

            XX1 = Sheets("月營收").Range("B1000000").End(xlUp).Row

                        Sheets("月營收").Range("$a$1:$J$" & XX1).AutoFilter Field:=3, Criteria1:= _

                                                                        "=" & list_data2(j) '

                         For O = LBound(list_data) To UBound(list_data) Step 1

                           Sheets("月營收").Range("$a$1:$J$" & XX1).AutoFilter Field:=4, Criteria1:= _

                                                                        "=" & list_data(O) '   

                                        Set 當月營收 = Sheets("月營收").Range("E1:E" & XX1).SpecialCells(xlCellTypeVisible)

                                        Set 當月營收12高 = Sheets("月營收").Range("L1:L" & XX1).SpecialCells(xlCellTypeVisible)

                                        Set 去年當月營收 = Sheets("月營收").Range("G1:G" & XX1).SpecialCells(xlCellTypeVisible)

                                         Sheets("產業別").Cells(ADD, 1).Value = list_data2(j)

                                         Sheets("產業別").Cells(ADD, 2).Value = list_data(O)

                                        Sheets("產業別").Cells(ADD, 3).Value = Application.Sum(當月營收)   

                                        Sheets("產業別").Cells(ADD, 4).Value = Application.Sum(去年當月營收)

                                        Sheets("產業別").Cells(ADD, 6).Value = Application.Sum(當月營收12高)

                                        On Error Resume Next

                                        Sheets("產業別").Cells(ADD, 5).Value = (Sheets("產業別").Cells(ADD, 3).Value - Sheets("產業別").Cells(ADD, 4).Value) / Sheets("產業別").Cells(ADD, 4).Value

                                         On Error GoTo LINE1

                                         ADD = ADD + 1

                            Next

                            Sheets("月營收").AutoFilterMode = False

                            Next

              Windows(SOURCE).Activate

              income_row_年增率 = Sheets("產業別").Range("a" & "65536").End(xlUp).Row

             Set myRange_R = Sheets("產業別").Range("A1:E" & income_row_年增率)

            myRange_R.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

             Set myRange_R = Nothing

     Application.ScreenUpdating = True

  Application.DisplayStatusBar = True

  Application.Calculation = xlCalculationAutomtic

  Application.EnableEvents = True


END SUB



2020年12月28日 星期一

VBA:AutoFilter應用:找特定時間區間,股價最高與最低值(YAHOO FINANCE CSV為例)

 RANGE有相當多的屬性跟方法,AutoFilter即為RANGE的方法之一,MSDN查詢結果,小小編由YAHOO FINANCE下載了某間公司的過去歷史股價,合計5200多筆收盤價資料,以此案例來實際操作一。範例下載

 P.S範例資料有略為簡化。

如果你經常在用YAHOO FINANCE下載資料來用,可以看看怎操作😀

至於批次找出各公司的最高最低價,有空在單獨寫一篇。

一、目的:找出該公司每一年最高與最低股價。

圖1.原始資料

二、IPO發想與評估:

每一年,所以有期間限制、最高最低價內建函數可以解決、是否要使用陣列的方式堆壘資料

2.1 IPO拆解步驟:

A.資料來源:在A到F行,A行為日期,B到E行為股價資料。

         B.怎處理: 

1.觀察資料與問題:

(1)資料為連續的,沒有空白,有完整日期標示可以免除資料前處理。

(2)現況資料有幾年?怎知道是那一年開始的?

(3)找出最大與最小分別可以透過MAX與MIN等內建函數完成。

(4)透過內建函數MAX與MIN,但對應的範圍怎設定才能是特定期間? 

2.滿足問題:

(1)有幾年這部分,因為資料是連續的,可以透過取的最後一筆資料跟第一筆資料來判斷需要執行幾年的期間,來設計迴圈。

(2)內建函數範圍設定這部分,回想到VBA:Cells.SpecialCells 簡單應用+ 資料排序一文,透過設定為xlCellTypeConstants方式來取的位置即可解決。

C.輸出 :

把年份找出來後,新增一頁工作表名為OUT,做各年份最高最低股價結果顯示與儲存用。 

2.2 評估:

每一年,所以有期間限制:OK

最高最低價內建函數可以解決:OK

是否要使用陣列的方式堆壘資料:股價不用天天整理最高最低,所以免用陣列。

三、動作寫:

     AutoFilter 簡單說明:

 Sheets("還原股價").Range("$A$1:$f$" & END_ROW).AutoFilter Field:=1, Criteria1:= _

           ">=" & year_begin & "/1/1", Operator:=xlAnd, Criteria2:="<=" & year_begin & "/12/31" 

Field:設定篩選的條件是第幾行。

Criteria1、Criteria1:因為是區間,所以要設定2個條件。

Operator:篩選類型設定,因為有兩個條件所以設為xlAnd。

year_begin:是透過迴圈控制的篩選變數,配合 "/1/1"與"/12/31" 組合成年頭與年末的篩選條件。

先作一個ACTIVEX按鈕插入以下VBA:


圖2.按鈕一測試結果


小小編突發奇想,想要知道股價日期,追加修改了一下:

在作一個ACTIVEX按鈕插入以下VBA: 

圖3.按鈕二測試結果


2026年8月11日 星期二

Excel VBA 工具集|案例操作教學

Excel VBA 工具集|案例操作教學(一步一步照著做)

Excel VBA 工具集|案例操作教學

9 大模組、每個檔案一套獨立案例操作:先準備資料 → 照步驟按巨集 → 對照預期結果,跟著做就能上手。

本頁為獨立 HTML 檔,可直接分享到部落格;程式碼區塊可展開 / 收合。

開始之前:匯入與執行方式

  1. 開啟 Excel,按 Alt + F11 進入 VBA 編輯器。
  2. 在專案總管右鍵工作簿 → 「匯入檔案」→ 選取要練習的那個 .bas 檔。
  3. 執行方式:在 VBA 編輯器中,把游標放在子程序名稱內,按 F5 執行。
  4. 若被擋下,請先「檔案 → 選項 → 信任中心 → 信任位置」加入此資料夾,或開啟檔案後按「啟用內容」。
  5. 匯入順序建議:JsonParser.bas 先匯入(08 日誌系統會用到它),其餘檔案彼此獨立、可單獨練習。
  6. 各單元的「準備資料」請照著打進工作表;欄位順序以該單元表格為準(每個範例的欄位假設不同)。
排序

01 資料排序

單元目標:練習用 VBA 將資料表排序:單欄排序(升序 / 降序)與多欄位排序。

操作檔案:01_SortData.bas

準備資料

在 Excel 新工作表第 1 列輸入表頭、第 2 列起輸入下列資料(此範例依巨集註解,第 2 欄為部門、第 3 欄為金額、第 5 欄為薪資)。

姓名部門金額交易日期薪資
張三業務部12,0002024/01/0552,000
李四技術部8,5002024/01/1248,000
王五業務部20,0002024/02/0161,000
陳六人資部5,0002024/02/1539,000
林七技術部15,0002024/03/0355,000

案例操作

操作 1:SortData

  1. 將游標停在 VBA 編輯器中 SortData 子程序內,按 F5。
  2. 跳出「排序方式」輸入框,輸入 1(升序)後按確定。
預期結果:工作表依第 3 欄「金額」由小到大排列:陳六 → 李四 → 張三 → 林七 → 王五,並跳出訊息「排序完成!依第 3 欄 升序 排列。」。再試一次輸入 2,會改為降序排列。

操作 2:SortMultiColumn

  1. 將游標停在 SortMultiColumn 內,按 F5(不需輸入)。
預期結果:先依第 2 欄「部門」升序,部門內再依第 5 欄「薪資」降序,順序為:陳六(人資部)→ 林七(技術部)→ 李四(技術部)→ 王五(業務部)→ 張三(業務部),並跳出「多欄位排序完成!」訊息。
資料排序 完整程式碼(參考用)
' ============================================================
' 範例一:資料排序 (Data Sorting)
' 功能:依指定欄位對資料進行排序(升序/降序)
' ============================================================

Sub SortData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim sortCol As Integer
    Dim sortOrder As XlSortOrder
    
    ' 取得工作表
    Set ws = ActiveSheet
    
    ' 取得資料範圍
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 判斷排序欄位(假設第3欄:金額)
    sortCol = 3
    
    ' 提示使用者排序方式
    sortOrder = InputBox("輸入 1 = 升序, 2 = 降序", "排序方式", "1")
    
    If sortOrder = "1" Then
        sortOrder = xlAscending
    ElseIf sortOrder = "2" Then
        sortOrder = xlDescending
    Else
        MsgBox "輸入錯誤!預設使用升序。"
        sortOrder = xlAscending
    End If
    
    ' 執行排序
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range(ws.Cells(2, sortCol), ws.Cells(lastRow, sortCol)), _
                        Order:=sortOrder
        .SetRange ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
        .Header = xlYes
        .Apply
    End With
    
    MsgBox "排序完成!依第 " & sortCol & " 欄 " & _
           IIf(sortOrder = xlAscending, "升序", "降序") & " 排列。", vbInformation
End Sub

Sub SortMultiColumn()
    ' 多欄位排序:先依部門(第2欄),再依薪資(第5欄)降序
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("B2:B" & lastRow), Order:=xlAscending   ' 部門 升序
        .SortFields.Add Key:=ws.Range("E2:E" & lastRow), Order:=xlDescending   ' 薪資 降序
        .SetRange ws.Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    
    MsgBox "多欄位排序完成!" & vbCr & _
           "1. 部門(升序)" & vbCr & _
           "2. 薪資(降序)", vbInformation
End Sub
這兩個巨集都固定寫死欄位編號,若你的資料欄位不同,請修改 SortData 的 sortCol 與 SortMultiColumn 中的 Range 欄位。
篩選

02 資料篩選與去重複

單元目標:練習用自動篩選、條件篩選、移除重複值,以及把篩選結果匯出到新工作表。

操作檔案:02_FilterAndDuplicates.bas

準備資料

在第 1 列輸入表頭、第 2 列起輸入下列資料。特別注意:張三 + 業務部 出現兩次,用來測試去重複。

姓名性別地區部門薪資
張三男北部銷售部52,000
李四女中部技術部48,000
王五男南部銷售部61,000
張三男北部銷售部55,000
陳六女北部人資部39,000
林七男中部技術部55,000

案例操作

操作 1:FilterData

  1. 游標停在 FilterData 內,按 F5。
預期結果:工作表自動篩選出第 4 欄為「銷售部」的列:張三、王五、張三 共 3 列,表頭列出現下拉篩選箭頭,並跳出「已篩選出「銷售部」的資料。」。

操作 2:FilterAdvanced

  1. 先取消篩選(資料 → 篩選 → 清除),再按 F5 執行 FilterAdvanced。
預期結果:篩選出第 5 欄「薪資 > 50,000」的資料:張三、王五、張三、林七 共 4 筆,並跳出「篩選完成!薪資 > 50000 的資料共 4 筆。」。

操作 3:RemoveDuplicates

  1. 先清除篩選,再按 F5 執行 RemoveDuplicates。
預期結果:依「姓名 + 部門」組合移除重複列,張三 + 銷售部 兩列只剩一列,跳出「原始資料:6 筆 / 去重複後:5 筆」訊息。

操作 4:ExportFilteredData

  1. 按 F5 執行 ExportFilteredData。
預期結果:先篩出「地區 = 北部」的 3 列(張三、張三、陳六),再複製到新工作表「北部資料」,並跳出「已將「北部」資料複製到新工作表「北部資料」。」。
資料篩選與去重複 完整程式碼(參考用)
' ============================================================
' 範例二:資料篩選與去重複 (Filter & Remove Duplicates)
' 功能:依條件篩選資料、移除重複值
' ============================================================

Sub FilterData()
    ' 篩選特定條件的資料
    Dim ws As Worksheet
    
    Set ws = ActiveSheet
    
    ' 關閉自動篩選(如果有)
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 依第4欄(部門)篩選「銷售部」
    ws.Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:="銷售部"
    
    MsgBox "已篩選出「銷售部」的資料。", vbInformation
End Sub

Sub FilterAdvanced()
    ' 進階篩選:依第5欄(薪資)篩選大於 50000 的資料
    Dim ws As Worksheet
    Dim lastRow As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 篩選薪資 > 50000
    ws.Range("A1:E" & lastRow).AutoFilter Field:=5, Criteria1:=">50000"
    
    ' 計算顯示的資料筆數
    Dim visibleRows As Long
    visibleRows = ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).Count
    
    MsgBox "篩選完成!薪資 > 50000 的資料共 " & visibleRows & " 筆。", vbInformation
End Sub

Sub RemoveDuplicates()
    ' 移除重複值
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim dupCount As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 依第1欄(姓名)與第4欄(部門)組合判斷重複
    dupCount = Application.WorksheetFunction.CountA(ws.Range("A:A")) - 1
    
    ws.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 4), Header:=xlYes
    
    MsgBox "去重複完成!" & vbCr & _
           "原始資料:" & dupCount & " 筆" & vbCr & _
           "去重複後:" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1 & " 筆", vbInformation
End Sub

Sub ExportFilteredData()
    ' 篩選後將結果複製到新的工作表
    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 篩選:第3欄(地區)為「北部」
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    ws.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:="北部"
    
    ' 複製篩選結果
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("北部資料").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsNew = Worksheets.Add
    wsNew.Name = "北部資料"
    
    ws.AutoFilter.Range.Copy
    wsNew.Range("A1").PasteSpecial xlPasteAll
    
    ' 關閉篩選
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Application.CutCopyMode = False
    
    MsgBox "已將「北部」資料複製到新工作表「北部資料」。", vbInformation
End Sub
RemoveDuplicates 會直接刪除原工作表的列,請先另存備份再執行。篩選條件與欄位編號(地區 3、部門 4、薪資 5)為巨集內寫死。
匯總

03 資料匯總與統計

單元目標:練習依部門與月份自動匯總:總和、平均、筆數、最高、最低。

操作檔案:03_SummarizeData.bas

準備資料

輸入下列銷售資料。重要:日期請用「文字」輸入(如 2024-01-05),因為巨集用 Left(日期,7) 取年月,若輸入成真正的日期格式(2024/1/5)會取錯月份。

日期業務員產品部門銷售金額
2024-01-05張三筆電業務部12,000
2024-01-12李四手機技術部8,500
2024-02-01王五平板業務部20,000
2024-02-15陳六印表機人資部5,000
2024-03-03林七桌機技術部15,000
2024-03-20張三筆電業務部11,000

案例操作

操作 1:SummarizeByDepartment

  1. 游標停在 SummarizeByDepartment 內按 F5,不需輸入。
預期結果:自動刪除並重建「部門匯總」工作表:業務部(薪資總和 43,000、人數 3、平均 14,333)、技術部(23,500、2、11,750)、人資部(5,000、1、5,000),並跳出「部門匯總完成!共 3 個部門。」。

操作 2:MonthlySalesSummary

  1. 游標停在 MonthlySalesSummary 內按 F5,不需輸入。
預期結果:建立「月度匯總」工作表,共 3 個月:2024-01(銷售總額 20,500、交易 2、平均 10,250、最高 12,000、最低 8,500)、2024-02(25,000、2、12,500、20,000、5,000)、2024-03(26,000、2、13,000、15,000、11,000)。

操作 3:CountIfAnalysis

  1. 游標停在 CountIfAnalysis 內按 F5。
  2. 在「請輸入要分析的部門名稱」輸入框輸入 業務部 後按確定。
預期結果:跳出「業務部 分析報告:人數 3、薪資總和 43,000、平均薪資 14,333」。輸入其他部門(如 人資部)也能立即得到結果。
資料匯總與統計 完整程式碼(參考用)
' ============================================================
' 範例三:資料匯總與統計 (Data Aggregation)
' 功能:依條件進行資料匯總、計算總和、平均、計數
' ============================================================

Sub SummarizeByDepartment()
    ' 依部門匯總資料:計算每個部門的薪資總和、平均薪資、人數
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim dept As String
    Dim salary As Double
    Dim resultRow As Long
    
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 讀取資料並匯總
    For i = 2 To lastRow
        dept = ws.Cells(i, 4).Value  ' 第4欄=部門
        salary = ws.Cells(i, 5).Value ' 第5欄=薪資
        
        If Not dict.Exists(dept) Then
            dict.Add dept, Array(0, 0, 0) ' totalSalary, count, avgHolder
        End If
        
        dict(dept)(0) = dict(dept)(0) + salary
        dict(dept)(1) = dict(dept)(1) + 1
    Next i
    
    ' 建立結果工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("部門匯總").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim wsResult As Worksheet
    Set wsResult = Worksheets.Add
    wsResult.Name = "部門匯總"
    
    ' 寫入標題
    wsResult.Range("A1").Value = "部門"
    wsResult.Range("B1").Value = "薪資總和"
    wsResult.Range("C1").Value = "人數"
    wsResult.Range("D1").Value = "平均薪資"
    
    ' 套用格式
    With wsResult.Range("A1:D1")
        .Font.Bold = True
        .Interior.Color = RGB(70, 130, 180)
        .Font.Color = vbWhite
    End With
    
    ' 寫入資料
    resultRow = 2
    Dim deptName As Variant
    For Each deptName In dict.Keys()
        wsResult.Cells(resultRow, 1).Value = deptName
        wsResult.Cells(resultRow, 2).Value = dict(deptName)(0)
        wsResult.Cells(resultRow, 3).Value = dict(deptName)(1)
        wsResult.Cells(resultRow, 4).Value = dict(deptName)(0) / dict(deptName)(1)
        resultRow = resultRow + 1
    Next deptName
    
    ' 自動調整欄寬
    wsResult.Columns.AutoFit
    
    MsgBox "部門匯總完成!共 " & dict.Count & " 個部門。", vbInformation
End Sub

Sub MonthlySalesSummary()
    ' 月度銷售匯總:計算每月銷售總額、平均單價、最高/最低銷售
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim monthKey As String
    Dim amount As Double
    
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 假設:第1欄=日期, 第3欄=產品, 第5欄=銷售金額
    For i = 2 To lastRow
        monthKey = Left(ws.Cells(i, 1).Value, 7)  ' 取年月 (YYYY-MM)
        amount = ws.Cells(i, 5).Value
        
        If Not dict.Exists(monthKey) Then
            dict.Add monthKey, Array(0, 0, 0, 0, 0) ' sum, count, max, min, avg
            dict(monthKey)(2) = 0  ' max init
            dict(monthKey)(3) = amount  ' min init
        End If
        
        dict(monthKey)(0) = dict(monthKey)(0) + amount
        dict(monthKey)(1) = dict(monthKey)(1) + 1
        
        If amount > dict(monthKey)(2) Then dict(monthKey)(2) = amount
        If amount < dict(monthKey)(3) Then dict(monthKey)(3) = amount
    Next i
    
    ' 建立結果工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("月度匯總").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim wsResult As Worksheet
    Set wsResult = Worksheets.Add
    wsResult.Name = "月度匯總"
    
    ' 標題
    wsResult.Range("A1").Value = "年月"
    wsResult.Range("B1").Value = "銷售總額"
    wsResult.Range("C1").Value = "交易次數"
    wsResult.Range("D1").Value = "平均銷售"
    wsResult.Range("E1").Value = "最高銷售"
    wsResult.Range("F1").Value = "最低銷售"
    
    With wsResult.Range("A1:F1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 128, 128)
        .Font.Color = vbWhite
    End With
    
    ' 寫入資料
    Dim month As Variant
    Dim rowIdx As Long
    rowIdx = 2
    
    Dim sortedMonths() As String
    ReDim sortedMonths(dict.Count - 1)
    Dim idx As Long
    idx = 0
    For Each month In dict.Keys()
        sortedMonths(idx) = month
        idx = idx + 1
    Next month
    
    ' 簡單排序
    Dim j As Long
    Dim temp As String
    For i = 0 To UBound(sortedMonths) - 1
        For j = i + 1 To UBound(sortedMonths)
            If sortedMonths(i) > sortedMonths(j) Then
                temp = sortedMonths(i)
                sortedMonths(i) = sortedMonths(j)
                sortedMonths(j) = temp
            End If
        Next j
    Next i
    
    For Each month In sortedMonths
        wsResult.Cells(rowIdx, 1).Value = month
        wsResult.Cells(rowIdx, 2).Value = dict(month)(0)
        wsResult.Cells(rowIdx, 3).Value = dict(month)(1)
        wsResult.Cells(rowIdx, 4).Value = dict(month)(0) / dict(month)(1)
        wsResult.Cells(rowIdx, 5).Value = dict(month)(2)
        wsResult.Cells(rowIdx, 6).Value = dict(month)(3)
        rowIdx = rowIdx + 1
    Next month
    
    wsResult.Columns.AutoFit
    
    MsgBox "月度銷售匯總完成!共 " & dict.Count & " 個月。", vbInformation
End Sub

Sub CountIfAnalysis()
    ' 使用 CountIf / SumIf 進行條件分析
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim targetDept As String
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    targetDept = InputBox("請輸入要分析的部門名稱:", "部門分析")
    
    If targetDept = "" Then Exit Sub
    
    Dim countVal As Long
    Dim sumVal As Double
    Dim avgVal As Double
    
    ' 計算人數
    countVal = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & lastRow), targetDept)
    
    ' 計算薪資總和
    sumVal = Application.WorksheetFunction.SumIf(ws.Range("D2:D" & lastRow), targetDept, ws.Range("E2:E" & lastRow))
    
    If countVal > 0 Then
        avgVal = sumVal / countVal
    End If
    
    MsgBox "=== " & targetDept & " 分析報告 ===" & vbCr & _
           "人數:" & countVal & vbCr & _
           "薪資總和:" & Format(sumVal, "#,##0") & vbCr & _
           "平均薪資:" & Format(avgVal, "#,##0"), vbInformation
End Sub
匯總結果都是新建工作表(部門匯總 / 月度匯總),執行前若已有同名工作表會被刪除重蓋。
標記

04 條件標記與視覺化

單元目標:練習用顏色自動標記:高於平均、重複資料、數值熱點圖、過期項目。

操作檔案:04_ConditionalHighlight.bas

準備資料

輸入下列資料。張三 + 業務部 故意重複兩列;到期日(第 2 欄)有幾個過期日期供測試標紅。

姓名到期日地區部門薪資
張三2024-01-15北部業務部52,000
李四2025-06-30中部技術部48,000
王五2023-12-31南部業務部61,000
張三2024-05-20北部業務部55,000
陳六2025-12-31北部人資部39,000
林七2024-08-15中部技術部55,000

案例操作

操作 1:HighlightTopPerformers

  1. 游標停在 HighlightTopPerformers 內按 F5,不需輸入。
預期結果:平均薪資約 51,667。張三、王五、張三、林七 這 4 列(薪資高於平均)整列標成淺綠色,資料表最下方新增一列「平均值」(橘色)。

操作 2:HighlightDuplicates

  1. 按 F5 執行 HighlightDuplicates。
預期結果:依「姓名 + 部門」組合比對,張三 + 業務部 出現的 2 列都被標成橘色,跳出「重複資料標記完成!共 1 筆重複。」。

操作 3:ColorScaleByValue

  1. 按 F5 執行 ColorScaleByValue。
預期結果:第 5 欄薪資依數值大小套用紅 → 綠漸層:最低 39,000 接近紅色、最高 61,000 接近綠色,中間依比例混合。

操作 4:MarkExpiredItems

  1. 按 F5 執行 MarkExpiredItems。
預期結果:第 2 欄日期早於「今天」的列整列標成紅色(範例中的 2024-01-15、2023-12-31、2024-05-20、2024-08-15 都小於執行當天),並跳出「過期項目標記完成!共 N 項過期。」。
條件標記與視覺化 完整程式碼(參考用)
' ============================================================
' 範例四:條件標記與視覺化 (Conditional Highlighting)
' 功能:依條件自動標記/顏色格式化資料
' ============================================================

Sub HighlightTopPerformers()
    ' 標記薪資高於平均值的員工
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim avgSalary As Double
    Dim totalSalary As Double
    Dim count As Long
    Dim i As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 計算平均薪資(第5欄)
    totalSalary = 0
    count = 0
    For i = 2 To lastRow
        If IsNumeric(ws.Cells(i, 5).Value) Then
            totalSalary = totalSalary + ws.Cells(i, 5).Value
            count = count + 1
        End If
    Next i
    
    If count = 0 Then
        MsgBox "找不到有效資料。", vbExclamation
        Exit Sub
    End If
    
    avgSalary = totalSalary / count
    
    ' 清除舊格式
    ws.Cells.Interior.ColorIndex = xlNone
    
    ' 標記高於平均值的員工
    Dim highlighted As Long
    highlighted = 0
    For i = 2 To lastRow
        If IsNumeric(ws.Cells(i, 5).Value) And ws.Cells(i, 5).Value > avgSalary Then
            ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).Interior.Color = RGB(144, 238, 144) ' 淺綠色
            highlighted = highlighted + 1
        End If
    Next i
    
    ' 標記平均值列
    Dim avgRow As Long
    avgRow = lastRow + 1
    ws.Cells(avgRow, 1).Value = "平均值"
    ws.Cells(avgRow, 1).Font.Bold = True
    ws.Cells(avgRow, 5).Value = avgSalary
    ws.Cells(avgRow, 5).NumberFormat = "#,##0"
    ws.Cells(avgRow, 1).Interior.Color = RGB(255, 165, 0) ' 橘色
    ws.Cells(avgRow, 5).Interior.Color = RGB(255, 165, 0)
    
    MsgBox "標記完成!" & vbCr & _
           "平均薪資:" & Format(avgSalary, "#,##0") & vbCr & _
           "高於平均的員工:" & highlighted & " 人", vbInformation
End Sub

Sub HighlightDuplicates()
    ' 標記重複的資料
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim key As String
    Dim dupCount As Long
    
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 清除舊格式
    ws.Cells.Interior.ColorIndex = xlNone
    
    ' 標記重複值(依第1欄+第4欄組合)
    dupCount = 0
    For i = 2 To lastRow
        key = ws.Cells(i, 1).Value & "|" & ws.Cells(i, 4).Value
        
        If dict.Exists(key) Then
            ' 標記當前列與之前出現的列
            ws.Range(ws.Cells(dict(key), 1), ws.Cells(dict(key), lastCol)).Interior.Color = RGB(255, 192, 0) ' 橘色
            ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).Interior.Color = RGB(255, 192, 0)
            dupCount = dupCount + 1
        Else
            dict.Add key, i
        End If
    Next i
    
    MsgBox "重複資料標記完成!共 " & dupCount & " 筆重複。", vbInformation
End Sub

Sub ColorScaleByValue()
    ' 依數值大小套用顏色比例(熱點圖效果)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim minVal As Double
    Dim maxVal As Double
    Dim i As Long
    Dim j As Long
    Dim ratio As Double
    Dim red As Integer
    Dim green As Integer
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 清除舊格式
    ws.Cells.Interior.ColorIndex = xlNone
    
    ' 假設第5欄為要顏色比例化的欄位
    minVal = ws.Cells(2, 5).Value
    maxVal = ws.Cells(2, 5).Value
    
    ' 找最小最大值
    For i = 2 To lastRow
        If IsNumeric(ws.Cells(i, 5).Value) Then
            If ws.Cells(i, 5).Value < minVal Then minVal = ws.Cells(i, 5).Value
            If ws.Cells(i, 5).Value > maxVal Then maxVal = ws.Cells(i, 5).Value
        End If
    Next i
    
    ' 套用顏色比例
    For i = 2 To lastRow
        If IsNumeric(ws.Cells(i, 5).Value) Then
            If maxVal = minVal Then
                ratio = 0.5
            Else
                ratio = (ws.Cells(i, 5).Value - minVal) / (maxVal - minVal)
            End If
            
            red = Int(255 * ratio)
            green = Int(255 * (1 - ratio))
            
            ws.Cells(i, 5).Interior.Color = RGB(red, green, 0)
        End If
    Next i
    
    MsgBox "顏色比例化完成!" & vbCr & _
           "最小值:" & minVal & "(紅色)" & vbCr & _
           "最大值:" & maxVal & "(綠色)", vbInformation
End Sub

Sub MarkExpiredItems()
    ' 標記過期的項目(假設第2欄為日期,超過今天即標記)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim expiredCount As Long
    Dim today As Date
    
    today = Date
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 清除舊格式
    ws.Cells.Interior.ColorIndex = xlNone
    
    expiredCount = 0
    For i = 2 To lastRow
        If IsDate(ws.Cells(i, 2).Value) Then
            If ws.Cells(i, 2).Value < today Then
                ws.Range(ws.Cells(i, 1), ws.Cells(i, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Interior.Color = RGB(255, 0, 0) ' 紅色
                expiredCount = expiredCount + 1
            End If
        End If
    Next i
    
    MsgBox "過期項目標記完成!共 " & expiredCount & " 項過期。", vbCritical
End Sub
這些巨集執行前都會先清除整張工作表的底色(Cells.Interior.ColorIndex = xlNone),請避免在已有格式的工作表上使用。
報告

05 自動化統計報告

單元目標:練習一鍵產出完整統計報告、清理資料空白、合併多張工作表並去重複。

操作檔案:05_ReportGeneration.bas

準備資料

輸入下列員工資料當作報告來源。

員工編號姓名部門薪資
E001張三業務部52,000
E002李四技術部48,000
E003王五業務部61,000
E004陳六人資部39,000

案例操作

操作 1:GenerateReport

自動分析整張資料表。

  1. 確認資料工作表為目前作用工作表,游標停在 GenerateReport 內按 F5。
預期結果:建立「統計報告」工作表,包含:一、基本資料概況(總資料筆數 4、欄位數量 4);二、數值欄位統計(薪資:平均 50,000、總和 200,000、最大 61,000、最小 39,000、計數 4);三、分類欄位統計(部門唯一值 3 個);四、報告資訊(生成日期、資料來源、總筆數)。

操作 2:AutoCleanData

清除文字欄位的前後空白。

  1. 先故意在任一個姓名儲存格輸入「 張三 」(前後各一個空白)。
  2. 按 F5 執行 AutoCleanData。
預期結果:所有文字欄位的前後空白被移除,「 張三 」變回「張三」,並跳出「資料清理完成!處理了 N 個欄位的空白字元。」。

操作 3:MergeAndDedupe

把工作簿內所有工作表合併去重複。

  1. 新增兩張結構相同的工作表(例如「一月」「二月」),各放 3 筆資料,其中一筆完全相同(例如都是「E002 李四 技術部 48,000」)。
  2. 游標停在 MergeAndDedupe 內按 F5。
預期結果:建立「合併資料」工作表,兩表資料合併,重複的那筆只保留一次,並跳出「合併完成!共 N 筆不重複資料。」。
自動化統計報告 完整程式碼(參考用)
' ============================================================
' 範例五:自動化統計報告 (Automated Report Generation)
' 功能:自動生成完整的資料分析報告
' ============================================================

Sub GenerateReport()
    ' 自動生成統計報告工作表
    Dim wsData As Worksheet
    Dim wsReport As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim reportRow As Long
    
    Set wsData = ActiveSheet
    lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
    lastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    
    If lastRow < 2 Then
        MsgBox "沒有足夠的資料可生成報告。", vbExclamation
        Exit Sub
    End If
    
    ' 建立報告工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("統計報告").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsReport = Worksheets.Add
    wsReport.Name = "統計報告"
    reportRow = 1
    
    ' ===== 報告標題 =====
    wsReport.Cells(reportRow, 1).Value = "資料分析報告"
    wsReport.Cells(reportRow, 1).Font.Size = 16
    wsReport.Cells(reportRow, 1).Font.Bold = True
    wsReport.Cells(reportRow, 1).Font.Color = RGB(0, 0, 128)
    reportRow = reportRow + 2
    
    ' ===== 一、基本資料概況 =====
    wsReport.Cells(reportRow, 1).Value = "一、基本資料概況"
    wsReport.Cells(reportRow, 1).Font.Bold = True
    wsReport.Cells(reportRow, 1).Font.Color = RGB(0, 0, 128)
    reportRow = reportRow + 1
    
    wsReport.Cells(reportRow, 1).Value = "總資料筆數:"
    wsReport.Cells(reportRow, 2).Value = lastRow - 1
    reportRow = reportRow + 1
    
    wsReport.Cells(reportRow, 1).Value = "欄位數量:"
    wsReport.Cells(reportRow, 2).Value = lastCol
    reportRow = reportRow + 2
    
    ' ===== 二、數值欄位統計 =====
    wsReport.Cells(reportRow, 1).Value = "二、數值欄位統計"
    wsReport.Cells(reportRow, 1).Font.Bold = True
    wsReport.Cells(reportRow, 1).Font.Color = RGB(0, 0, 128)
    reportRow = reportRow + 1
    
    ' 寫入表頭
    wsReport.Cells(reportRow, 1).Value = "欄位名稱"
    wsReport.Cells(reportRow, 2).Value = "平均值"
    wsReport.Cells(reportRow, 3).Value = "總和"
    wsReport.Cells(reportRow, 4).Value = "最大值"
    wsReport.Cells(reportRow, 5).Value = "最小值"
    wsReport.Cells(reportRow, 6).Value = "計數"
    
    With wsReport.Range(wsReport.Cells(reportRow, 1), wsReport.Cells(reportRow, 6))
        .Font.Bold = True
        .Interior.Color = RGB(70, 130, 180)
        .Font.Color = vbWhite
    End With
    reportRow = reportRow + 1
    
    ' 分析每個欄位
    Dim i As Long
    Dim colStats As Variant
    Dim colName As String
    
    For i = 1 To lastCol
        colName = wsData.Cells(1, i).Value
        
        ' 嘗試判斷是否為數值欄位
        Dim firstVal As Variant
        Dim j As Long
        firstVal = ""
        For j = 2 To lastRow
            If Not IsEmpty(wsData.Cells(j, i).Value) Then
                firstVal = wsData.Cells(j, i).Value
                Exit For
            End If
        Next j
        
        If IsNumeric(firstVal) And Not IsEmpty(firstVal) Then
            On Error Resume Next
            colStats = CalculateColumnStats(wsData, i, lastRow)
            On Error GoTo 0
            
            If Not IsEmpty(colStats) Then
                wsReport.Cells(reportRow, 1).Value = colName
                wsReport.Cells(reportRow, 2).Value = colStats(0)
                wsReport.Cells(reportRow, 3).Value = colStats(1)
                wsReport.Cells(reportRow, 4).Value = colStats(2)
                wsReport.Cells(reportRow, 5).Value = colStats(3)
                wsReport.Cells(reportRow, 6).Value = colStats(4)
                reportRow = reportRow + 1
            End If
        End If
    Next i
    
    reportRow = reportRow + 2
    
    ' ===== 三、非數值欄位(唯一值統計) =====
    wsReport.Cells(reportRow, 1).Value = "三、分類欄位統計"
    wsReport.Cells(reportRow, 1).Font.Bold = True
    wsReport.Cells(reportRow, 1).Font.Color = RGB(0, 0, 128)
    reportRow = reportRow + 1
    
    wsReport.Cells(reportRow, 1).Value = "欄位名稱"
    wsReport.Cells(reportRow, 2).Value = "唯一值數量"
    wsReport.Cells(reportRow, 3).Value = "總計數"
    
    With wsReport.Range(wsReport.Cells(reportRow, 1), wsReport.Cells(reportRow, 3))
        .Font.Bold = True
        .Interior.Color = RGB(70, 130, 180)
        .Font.Color = vbWhite
    End With
    reportRow = reportRow + 1
    
    For i = 1 To lastCol
        colName = wsData.Cells(1, i).Value
        
        ' 判斷是否為非數值欄位
        Dim firstNonNum As Variant
        For j = 2 To lastRow
            If Not IsEmpty(wsData.Cells(j, i).Value) Then
                firstNonNum = wsData.Cells(j, i).Value
                Exit For
            End If
        Next j
        
        If Not IsNumeric(firstNonNum) Or IsEmpty(firstNonNum) Then
            Dim uniqueCount As Long
            uniqueCount = CountUniqueValues(wsData, i, lastRow)
            
            wsReport.Cells(reportRow, 1).Value = colName
            wsReport.Cells(reportRow, 2).Value = uniqueCount
            wsReport.Cells(reportRow, 3).Value = lastRow - 1
            reportRow = reportRow + 1
        End If
    Next i
    
    reportRow = reportRow + 2
    
    ' ===== 四、報告資訊 =====
    wsReport.Cells(reportRow, 1).Value = "四、報告資訊"
    wsReport.Cells(reportRow, 1).Font.Bold = True
    wsReport.Cells(reportRow, 1).Font.Color = RGB(0, 0, 128)
    reportRow = reportRow + 1
    
    wsReport.Cells(reportRow, 1).Value = "生成日期:"
    wsReport.Cells(reportRow, 2).Value = Now
    reportRow = reportRow + 1
    wsReport.Cells(reportRow, 1).Value = "資料來源:"
    wsReport.Cells(reportRow, 2).Value = wsData.Name
    reportRow = reportRow + 1
    wsReport.Cells(reportRow, 1).Value = "總筆數:"
    wsReport.Cells(reportRow, 2).Value = lastRow - 1
    
    ' 自動調整欄寬
    wsReport.Columns.AutoFit
    
    MsgBox "報告生成完成!已建立「統計報告」工作表。", vbInformation
End Sub

Function CalculateColumnStats(ws As Worksheet, colIndex As Integer, lastRow As Long) As Variant
    ' 計算欄位統計:平均值、總和、最大值、最小值、計數
    Dim total As Double
    Dim maxVal As Double
    Dim minVal As Double
    Dim count As Long
    Dim i As Long
    
    total = 0
    count = 0
    maxVal = -9.9E+308
    minVal = 9.9E+308
    
    For i = 2 To lastRow
        If IsNumeric(ws.Cells(i, colIndex).Value) And Not IsEmpty(ws.Cells(i, colIndex).Value) Then
            total = total + ws.Cells(i, colIndex).Value
            count = count + 1
            
            If ws.Cells(i, colIndex).Value > maxVal Then maxVal = ws.Cells(i, colIndex).Value
            If ws.Cells(i, colIndex).Value < minVal Then minVal = ws.Cells(i, colIndex).Value
        End If
    Next i
    
    If count > 0 Then
        CalculateColumnStats = Array(total / count, total, maxVal, minVal, count)
    Else
        CalculateColumnStats = Empty
    End If
End Function

Function CountUniqueValues(ws As Worksheet, colIndex As Integer, lastRow As Long) As Long
    ' 計算欄位的唯一值數量
    Dim dict As Object
    Dim i As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 2 To lastRow
        If Not IsEmpty(ws.Cells(i, colIndex).Value) Then
            dict(ws.Cells(i, colIndex).Value) = True
        End If
    Next i
    
    CountUniqueValues = dict.Count
End Function

Sub AutoCleanData()
    ' 資料清理工具:移除空值、去除空白、統一格式
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long
    Dim j As Long
    Dim cleaned As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    cleaned = 0
    
    ' 去除文字欄位的前後空白
    For i = 1 To lastRow
        For j = 1 To lastCol
            If TypeName(ws.Cells(i, j).Value) = "String" Then
                If ws.Cells(i, j).Value <> Trim(ws.Cells(i, j).Value) Then
                    ws.Cells(i, j).Value = Trim(ws.Cells(i, j).Value)
                    cleaned = cleaned + 1
                End If
            End If
        Next j
    Next i
    
    MsgBox "資料清理完成!" & vbCr & _
           "處理了 " & cleaned & " 個欄位的空白字元。", vbInformation
End Sub

Sub MergeAndDedupe()
    ' 合併多個工作表資料並去重複
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim ws As Worksheet
    Dim targetLastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim key As String
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 建立目標工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("合併資料").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsTarget = Worksheets.Add
    wsTarget.Name = "合併資料"
    
    ' 複製標題列
    Set wsSource = ActiveSheet
    wsSource.Range("A1").CurrentRegion.Rows(1).Copy
    wsTarget.Range("A1").PasteSpecial xlPasteAll
    targetLastRow = 1
    
    ' 遍歷所有工作表
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsTarget.Name Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            
            If lastRow > 1 Then
                For i = 2 To lastRow
                    key = ""
                    Dim lastCol As Integer
                    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                    
                    Dim colIdx As Integer
                    For colIdx = 1 To lastCol
                        key = key & ws.Cells(i, colIdx).Value & "|"
                    Next colIdx
                    
                    If Not dict.Exists(key) Then
                        dict.Add key, True
                        
                        ' 複製資料列
                        ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).Copy
                        targetLastRow = targetLastRow + 1
                        wsTarget.Cells(targetLastRow, 1).PasteSpecial xlPasteAll
                    End If
                Next i
            End If
        End If
    Next ws
    
    Application.CutCopyMode = False
    wsTarget.Columns.AutoFit
    
    MsgBox "合併完成!" & vbCr & _
           "共 " & dict.Count & " 筆不重複資料。", vbInformation
End Sub
GenerateReport 會自動判斷欄位是否為數值;文字欄位則統計唯一值數量。MergeAndDedupe 會把工作簿「所有」工作表都合併進來,請確認沒有不該合併的附表。
網路爬蟲

06 Yahoo Finance 股價爬蟲

單元目標:練習抓取即時股價、多股行情、下載歷史資料與布林通道分析。(需網路連線)

操作檔案:06_YahooFinanceStockScraper.bas

準備資料

本單元不需要準備資料表格。注意:即時報價功能在 06 模組內無法運作,必須改用 JsonParser.bas 內的巨集,下面步驟已標明「檔案」。

案例操作

操作 1:GetRealtimePriceFull(JsonParser.bas)

查單一股票即時報價。

  1. 確認已匯入 JsonParser.bas(需在 06 之前匯入也可以,兩者獨立)。
  2. 在 JsonParser 模組中,游標停在 GetRealtimePriceFull 內按 F5。
  3. 在輸入框輸入 2330.TW(台積電)後按確定,等待數秒。
預期結果:跳出完整的報價訊息框:股票名稱、交易所、貨幣、收盤價、前日收盤、開盤、最高、最低、成交量、漲跌、漲跌幅與查詢時間。輸入 AAPL、0700.HK 可查美股與港股。

操作 2:GetMultiplePricesFull(JsonParser.bas)

一次查詢多支股票並寫入工作表。

  1. 在 JsonParser 模組中按 F5 執行 GetMultiplePricesFull。
  2. 輸入 2330.TW,2454.TW,AAPL 後按確定。
預期結果:建立「Yahoo股價」工作表,每支股票一行(代號、名稱、目前價、前日收盤、開盤、最高、最低、成交量、漲跌、漲幅%、貨幣),上漲列為紅字、下跌列為綠字,並跳出「查詢完成!成功 3 / 3 支股票。」。

操作 3:DownloadHistoricalData(06 本檔)

下載歷史股價 CSV 到工作表。

  1. 在 06 模組中,游標停在 DownloadHistoricalData 內按 F5。
  2. 依序輸入股票代號 2330.TW、起始日期 2024-01-01、結束日期(預設為今天,直接按確定)。
預期結果:建立「2330.TW_歷史」工作表,欄位為 日期 / 開盤 / 最高 / 最低 / 收盤 / 成交量 / 調整後收盤,共約一年的日資料。此巨集不需解析 JSON,可正常運作。

操作 4:BollingerBandsAnalysis(06 本檔)

用一年歷史資料計算布林通道並出圖。

  1. 在 06 模組中按 F5 執行 BollingerBandsAnalysis。
  2. 輸入股票代號 2330.TW 後按確定(會自動下載近一年資料)。
預期結果:建立「2330.TW_布林通道」工作表:20 日均線、上軌(+2SD)、下軌(-2SD)、通道寬度、%B 與信號(突破上軌看跌 / 跌破下軌看涨 / 偏高 / 偏低 / 區間),並自動產生一張股價走勢折線圖。

操作 5:GetMarketIndices(06 本檔,會失敗)

抓取全球大盤指數。

  1. 在 06 模組中按 F5 執行 GetMarketIndices。
預期結果:會跳出「取得資料失敗」的訊息框。原因是 06 內建的 ParseJson 是空殼函數(永遠回傳 Nothing),此巨集目前無法正常使用,也沒有對應的替代巨集。
Yahoo Finance 股價爬蟲 完整程式碼(參考用)
' ============================================================
' Yahoo Finance 股價爬蟲範例
' 功能:使用 Yahoo Finance API 取得即時股價、歷史股價
' ============================================================

Option Explicit

' ============================================================
' 一、取得即時股價(單一股票)
' ============================================================

Sub GetRealtimePrice()
    ' 使用 Yahoo Finance Chart API 取得即時股價
    Dim symbol As String
    Dim url As String
    Dim http As Object
    Dim json As Object
    Dim result As String
    
    symbol = InputBox("請輸入股票代號(例如:2330.TW、AAPL、TSLA):", "Yahoo Finance 股價查詢")
    If symbol = "" Then Exit Sub
    
    ' Yahoo Finance API URL
    url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36"
    http.Send
    
    result = http.responseText
    
    ' 解析 JSON 結果
    Set json = ParseJson(result)
    
    If json Is Nothing Then
        MsgBox "取得資料失敗,請檢查股票代號是否正確。", vbExclamation
        Exit Sub
    End If
    
    ' 取得目前價格
    Dim meta As Object
    Dim chart As Object
    Dim quote As Object
    
    Set chart = json("chart")
    Set meta = chart("meta")
    Set quote = meta("regularMarketPrice")
    
    Dim currentPrice As Double
    currentPrice = CDbl(quote)
    
    Dim previousClose As Double
    previousClose = CDbl(meta("previousClose"))
    
    Dim change As Double
    Dim changePercent As Double
    change = currentPrice - previousClose
    changePercent = (change / previousClose) * 100
    
    ' 顯示結果
    Dim msg As String
    msg = "=== " & meta("symbol") & " 即時股價 ===" & vbCrLf
    msg = msg & "股票名稱:" & meta("shortName") & vbCrLf
    msg = msg & "目前價格:" & Format(currentPrice, "#,##0.00") & vbCrLf
    msg = msg & "前日收盤:" & Format(previousClose, "#,##0.00") & vbCrLf
    msg = msg & "漲跌:" & Format(change, "+#,##0.00;-#,##0.00;0") & vbCrLf
    msg = msg & "漲跌幅:" & Format(changePercent, "+0.00;-0.00;0.00") & "%" & vbCrLf
    msg = msg & "currency:" & meta("currency") & vbCrLf
    msg = msg & "交易所:" & meta("exchangeName")
    
    MsgBox msg, vbInformation, "Yahoo Finance"
End Sub

' ============================================================
' 二、取得即時股價(多支股票)
' ============================================================

Sub GetMultiplePrices()
    ' 取得多支股票即時股價並寫入工作表
    Dim symbols As String
    Dim symbolList() As String
    Dim i As Long
    Dim url As String
    Dim http As Object
    Dim json As Object
    Dim result As String
    
    symbols = InputBox("請輸入股票代號,以逗號分隔(例如:2330.TW,2454.TW,AAPL,TSLA):", "多股查詢")
    If symbols = "" Then Exit Sub
    
    symbolList = Split(symbols, ",")
    
    ' 建立結果工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("即時股價").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = "即時股價"
    
    ' 寫入標題
    ws.Range("A1").Value = "股票代號"
    ws.Range("B1").Value = "股票名稱"
    ws.Range("C1").Value = "目前價格"
    ws.Range("D1").Value = "前日收盤"
    ws.Range("E1").Value = "漲跌"
    ws.Range("F1").Value = "漲跌幅(%)"
    ws.Range("G1").Value = "最高"
    ws.Range("H1").Value = "最低"
    ws.Range("I1").Value = "開盤"
    ws.Range("J1").Value = "成交量"
    ws.Range("K1").Value = "currency"
    
    With ws.Range("A1:K1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    Dim rowIdx As Long
    rowIdx = 2
    
    For i = LBound(symbolList) To UBound(symbolList)
        Dim symbol As String
        symbol = Trim(symbolList(i))
        If symbol = "" Then GoTo NextSymbol
        
        url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
        http.Open "GET", url, False
        http.setRequestHeader "User-Agent", "Mozilla/5.0"
        http.Send
        
        result = http.responseText
        Set json = ParseJson(result)
        
        If Not json Is Nothing Then
            Dim meta As Object
            Dim quote As Object
            Set meta = json("chart")("meta")
            Set quote = meta("currentQuote")
            
            ws.Cells(rowIdx, 1).Value = meta("symbol")
            ws.Cells(rowIdx, 2).Value = meta("shortName")
            
            If Not IsNull(meta("regularMarketPrice")) Then
                ws.Cells(rowIdx, 3).Value = CDbl(meta("regularMarketPrice"))
            End If
            ws.Cells(rowIdx, 4).Value = CDbl(meta("previousClose"))
            
            If Not IsNull(quote) And Not IsNull(meta("regularMarketPrice")) Then
                Dim chg As Double
                chg = CDbl(meta("regularMarketPrice")) - CDbl(meta("previousClose"))
                ws.Cells(rowIdx, 5).Value = chg
                ws.Cells(rowIdx, 6).Value = (chg / CDbl(meta("previousClose"))) * 100
            End If
            
            ws.Cells(rowIdx, 7).Value = CDbl(meta("regularMarketDayHigh"))
            ws.Cells(rowIdx, 8).Value = CDbl(meta("regularMarketDayLow"))
            ws.Cells(rowIdx, 9).Value = CDbl(meta("regularMarketOpen"))
            ws.Cells(rowIdx, 10).Value = CLng(meta("regularMarketVolume"))
            ws.Cells(rowIdx, 11).Value = meta("currency")
            
            ' 漲跌幅顏色
            If ws.Cells(rowIdx, 6).Value > 0 Then
                ws.Cells(rowIdx, 5).Font.Color = vbRed
                ws.Cells(rowIdx, 6).Font.Color = vbRed
            ElseIf ws.Cells(rowIdx, 6).Value < 0 Then
                ws.Cells(rowIdx, 5).Font.Color = vbGreen
                ws.Cells(rowIdx, 6).Font.Color = vbGreen
            End If
        Else
            ws.Cells(rowIdx, 1).Value = symbol
            ws.Cells(rowIdx, 3).Value = "取得失敗"
        End If
        
        rowIdx = rowIdx + 1

NextSymbol:
    Next i
    
    ws.Columns.AutoFit
    MsgBox "已取得 " & (rowIdx - 2) & " 支股票資料。", vbInformation
End Sub

' ============================================================
' 三、下載歷史股價資料
' ============================================================

Sub DownloadHistoricalData()
    ' 使用 Yahoo Finance CSV 下載 API 取得歷史股價
    Dim symbol As String
    Dim startDate As String
    Dim endDate As String
    Dim url As String
    Dim http As Object
    Dim csvText As String
    Dim lines() As String
    Dim i As Long
    
    symbol = InputBox("請輸入股票代號:", "歷史股價下載", "2330.TW")
    If symbol = "" Then Exit Sub
    
    startDate = InputBox("請輸入起始日期 (YYYY-MM-DD):", "日期設定", "2024-01-01")
    If startDate = "" Then Exit Sub
    
    endDate = InputBox("請輸入結束日期 (YYYY-MM-DD):", "日期設定", DateToStr(Date))
    If endDate = "" Then Exit Sub
    
    ' Yahoo Finance CSV 下載 API
    url = "https://query1.finance.yahoo.com/v7/finance/download/" & symbol & _
          "?period1=" & DateToUnix(startDate) & _
          "&period2=" & DateToUnix(endDate) & _
          "&interval=1d&events=history"
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    http.Send
    
    csvText = http.responseText
    
    If InStr(csvText, "Error") > 0 Or InStr(csvText, "symbol") = 0 Then
        MsgBox "下載失敗,請檢查日期範圍或股票代號。", vbExclamation
        Exit Sub
    End If
    
    ' 建立工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(symbol & "_歷史").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = symbol & "_歷史"
    
    ' 寫入標題
    ws.Range("A1:G1").Value = Array("日期", "開盤", "最高", "最低", "收盤", "成交量", "調整後收盤")
    
    With ws.Range("A1:G1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    ' 解析 CSV
    lines = Split(csvText, vbCrLf)
    
    For i = 1 To UBound(lines)
        If lines(i) <> "" Then
            Dim fields() As String
            fields = Split(lines(i), ",")
            
            ws.Cells(i + 1, 1).Value = ParseDate(CStr(fields(0)))
            ws.Cells(i + 1, 2).Value = CDbl(fields(1))  ' Open
            ws.Cells(i + 1, 3).Value = CDbl(fields(2))  ' High
            ws.Cells(i + 1, 4).Value = CDbl(fields(3))  ' Low
            ws.Cells(i + 1, 5).Value = CDbl(fields(4))  ' Close
            ws.Cells(i + 1, 6).Value = CLng(fields(5))  ' Volume
            ws.Cells(i + 1, 7).Value = CDbl(fields(6))  ' Adj Close
        End If
    Next i
    
    ' 設定格式
    ws.Range("B2:B" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row).NumberFormat = "#,##0.00"
    ws.Range("C2:C" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row).NumberFormat = "#,##0.00"
    ws.Range("D2:D" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row).NumberFormat = "#,##0.00"
    ws.Range("E2:E" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row).NumberFormat = "#,##0.00"
    ws.Range("G2:G" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row).NumberFormat = "#,##0.00"
    ws.Columns.AutoFit
    
    MsgBox "已下載 " & (UBound(lines) - 1) & " 筆歷史資料至「" & symbol & "_歷史」。", vbInformation
End Sub

' ============================================================
' 四、取得大盤指數
' ============================================================

Sub GetMarketIndices()
    ' 取得主要大盤指數
    Dim indices As Variant
    Dim i As Long
    Dim url As String
    Dim http As Object
    Dim json As Object
    Dim result As String
    
    indices = Array("^GSPTSE", "^N225", "^STI", "^GSPC", "^IXIC", "^DJI", "^TWII", "^HSI")
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("大盤指數").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = "大盤指數"
    
    ws.Range("A1").Value = "指數名稱"
    ws.Range("B1").Value = "代號"
    ws.Range("C1").Value = "目前值"
    ws.Range("D1").Value = "漲跌"
    ws.Range("E1").Value = "漲跌幅(%)"
    
    With ws.Range("A1:E1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    Dim rowIdx As Long
    rowIdx = 2
    
    For i = LBound(indices) To UBound(indices)
        Dim sym As String
        sym = indices(i)
        
        url = "https://query1.finance.yahoo.com/v8/finance/chart/" & sym
        http.Open "GET", url, False
        http.setRequestHeader "User-Agent", "Mozilla/5.0"
        http.Send
        
        result = http.responseText
        Set json = ParseJson(result)
        
        If Not json Is Nothing Then
            Dim meta As Object
            Set meta = json("chart")("meta")
            
            ws.Cells(rowIdx, 1).Value = meta("shortName")
            ws.Cells(rowIdx, 2).Value = meta("symbol")
            ws.Cells(rowIdx, 3).Value = CDbl(meta("regularMarketPrice"))
            
            Dim prevClose As Double
            prevClose = CDbl(meta("previousClose"))
            ws.Cells(rowIdx, 4).Value = CDbl(meta("regularMarketPrice")) - prevClose
            ws.Cells(rowIdx, 5).Value = ((CDbl(meta("regularMarketPrice")) - prevClose) / prevClose) * 100
            
            ' 顏色標記
            If ws.Cells(rowIdx, 5).Value > 0 Then
                ws.Cells(rowIdx, 4).Font.Color = vbRed
                ws.Cells(rowIdx, 5).Font.Color = vbRed
            Else
                ws.Cells(rowIdx, 4).Font.Color = vbGreen
                ws.Cells(rowIdx, 5).Font.Color = vbGreen
            End If
        Else
            ws.Cells(rowIdx, 2).Value = sym
            ws.Cells(rowIdx, 3).Value = "取得失敗"
        End If
        
        rowIdx = rowIdx + 1
    Next i
    
    ws.Columns.AutoFit
    MsgBox "已取得 " & UBound(indices) + 1 & " 個大盤指數。", vbInformation
End Sub

' ============================================================
' 五、布林通道分析(使用歷史資料)
' ============================================================

Sub BollingerBandsAnalysis()
    ' 計算布林通道並標記突破信號
    Dim symbol As String
    Dim period As Integer
    Dim stdDevMult As Double
    
    symbol = InputBox("請輸入股票代號:", "布林通道分析", "2330.TW")
    If symbol = "" Then Exit Sub
    
    period = 20
    stdDevMult = 2
    
    ' 先下載歷史資料
    Dim startDate As String
    Dim endDate As String
    Dim url As String
    Dim http As Object
    Dim csvText As String
    Dim lines() As String
    Dim i As Long
    Dim dataCount As Long
    
    startDate = DateToStr(DateAdd("d", -365, Date))
    endDate = DateToStr(Date)
    
    url = "https://query1.finance.yahoo.com/v7/finance/download/" & symbol & _
          "?period1=" & DateToUnix(startDate) & _
          "&period2=" & DateToUnix(endDate) & _
          "&interval=1d&events=history"
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    http.Send
    
    csvText = http.responseText
    lines = Split(csvText, vbCrLf)
    dataCount = 0
    
    ' 讀取收盤價
    Dim closePrices() As Double
    Dim dates() As String
    ReDim closePrices(UBound(lines))
    ReDim dates(UBound(lines))
    
    For i = 1 To UBound(lines)
        If lines(i) <> "" Then
            Dim fields() As String
            fields = Split(lines(i), ",")
            dataCount = dataCount + 1
            closePrices(dataCount) = CDbl(fields(4))  ' Close
            dates(dataCount) = ParseDate(CStr(fields(0)))
        End If
    Next i
    
    ReDim Preserve closePrices(dataCount)
    ReDim Preserve dates(dataCount)
    
    If dataCount < period + 1 Then
        MsgBox "資料不足,至少需要 " & (period + 1) & " 筆資料。", vbExclamation
        Exit Sub
    End If
    
    ' 建立結果工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(symbol & "_布林通道").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = symbol & "_布林通道"
    
    ws.Range("A1").Value = "日期"
    ws.Range("B1").Value = "收盤價"
    ws.Range("C1").Value = "20日均線"
    ws.Range("D1").Value = "上軌(+2SD)"
    ws.Range("E1").Value = "下軌(-2SD)"
    ws.Range("F1").Value = "通道寬度(%)"
    ws.Range("G1").Value = "位置(%B)"
    ws.Range("H1").Value = "信號"
    
    With ws.Range("A1:H1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    ' 計算布林通道
    Dim rowIdx As Long
    rowIdx = 2
    
    Dim j As Long
    Dim sum As Double
    Dim avg As Double
    Dim sumSq As Double
    Dim stdDev As Double
    Dim upperBand As Double
    Dim lowerBand As Double
    Dim bandwidth As Double
    Dim percentB As Double
    
    For i = period + 1 To dataCount
        ' 計算均線
        sum = 0
        For j = i - period + 1 To i
            sum = sum + closePrices(j)
        Next j
        avg = sum / period
        
        ' 計算標準差
        sumSq = 0
        For j = i - period + 1 To i
            sumSq = sumSq + (closePrices(j) - avg) ^ 2
        Next j
        stdDev = Sqr(sumSq / period)
        
        ' 布林通道
        upperBand = avg + stdDevMult * stdDev
        lowerBand = avg - stdDevMult * stdDev
        bandwidth = ((upperBand - lowerBand) / avg) * 100
        
        ' %B 指標
        If upperBand <> lowerBand Then
            percentB = (closePrices(i) - lowerBand) / (upperBand - lowerBand)
        Else
            percentB = 0.5
        End If
        
        ' 信號判斷
        Dim signal As String
        If closePrices(i) > upperBand Then
            signal = "突破上軌▼看跌"
            ws.Cells(rowIdx, 8).Font.Color = vbGreen
        ElseIf closePrices(i) < lowerBand Then
            signal = "跌破下軌▲看涨"
            ws.Cells(rowIdx, 8).Font.Color = vbRed
        ElseIf percentB > 0.8 Then
            signal = "偏高"
            ws.Cells(rowIdx, 8).Font.Color = vbGreen
        ElseIf percentB < 0.2 Then
            signal = "偏低"
            ws.Cells(rowIdx, 8).Font.Color = vbRed
        Else
            signal = "區間"
            ws.Cells(rowIdx, 8).Font.Color = vbBlack
        End If
        
        ws.Cells(rowIdx, 1).Value = dates(i)
        ws.Cells(rowIdx, 2).Value = closePrices(i)
        ws.Cells(rowIdx, 3).Value = Round(avg, 2)
        ws.Cells(rowIdx, 4).Value = Round(upperBand, 2)
        ws.Cells(rowIdx, 5).Value = Round(lowerBand, 2)
        ws.Cells(rowIdx, 6).Value = Round(bandwidth, 2)
        ws.Cells(rowIdx, 7).Value = Round(percentB, 4)
        ws.Cells(rowIdx, 8).Value = signal
        
        rowIdx = rowIdx + 1
    Next i
    
    ws.Columns.AutoFit
    
    ' 產生簡單圖表
    Dim cht As ChartObject
    Set cht = ChartObjects.Add(500, 20, 600, 350)
    With cht.Chart
        .SetSourceData ws.Range("A2:B" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = symbol & " 股價走勢"
    End With
    
    MsgBox "布林通道分析完成!共 " & (rowIdx - 2) & " 筆分析資料。", vbInformation
End Sub

' ============================================================
' 輔助函數
' ============================================================

Function DateToStr(d As Date) As String
    ' 日期轉 YYYY-MM-DD 字串
    DateToStr = Year(d) & "-" & Right("0" & Month(d), 2) & "-" & Right("0" & Day(d), 2)
End Function

Function DateToUnix(dateStr As String) As Long
    ' 日期轉 Unix 時間戳記
    Dim d As Date
    d = CDate(dateStr)
    DateToUnix = CLng((d - DateValue("1/1/1970")) * 86400)
End Function

Function ParseDate(dateStr As String) As String
    ' 解析 Yahoo CSV 日期格式
    On Error Resume Next
    Dim parts() As String
    parts = Split(dateStr, "/")
    If UBound(parts) = 2 Then
        ParseDate = "20" & Right(parts(2), 2) & "-" & parts(0) & "-" & parts(1)
    Else
        ParseDate = dateStr
    End If
    On Error GoTo 0
End Function

Function ParseJson(jsonText As String) As Object
    ' 使用 MS JSON Parser 或簡單 JSON 解析
    ' 注意:VBA 內建不支援 JSON,需安裝 json-vba 庫或使用其他方法
    
    On Error Resume Next
    Dim parser As Object
    Set parser = CreateObject("ScriptControl")
    parser.Language = "JScript"
    
    ' 使用 JScript 解析 JSON
    Dim script As String
    script = "var json = " & jsonText & ";" & vbCr & "json;"
    
    On Error GoTo 0
    Set ParseJson = Nothing
End Function

' ============================================================
' 快速查詢:單一股票最新收盤價(簡單版)
' ============================================================

Sub QuickPriceCheck()
    ' 快速查詢:不需要完整 JSON 解析
    Dim symbol As String
    Dim url As String
    Dim http As Object
    Dim response As String
    
    symbol = "2330.TW"  ' 可修改為其他股票代號
    
    ' 使用 Yahoo Finance quoteSummary API
    url = "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & symbol & _
          "?modules=price,summaryDetail"
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64)"
    http.setRequestHeader "Accept", "application/json"
    http.Send
    
    response = http.responseText
    
    ' 輸出原始回應(方便除錯)
    Debug.Print response
    
    If Len(response) > 0 And InStr(response, "symbol") > 0 Then
        MsgBox "成功取得「" & symbol & "」資料。" & vbCrLf & _
               "詳細數據請查看立即視窗 (Ctrl+G)。", vbInformation
    Else
        MsgBox "取得資料失敗,回應:" & Mid(response, 1, 200), vbExclamation
    End If
End Sub
提醒:即時 / 多股報價請改用 JsonParser.bas 的 GetRealtimePriceFull、GetMultiplePricesFull;06 只有歷史下載與布林通道可用。JSON 解析依賴 MSScriptControl.ScriptControl(僅 32 位元 Office 可用)。
驗證

07 資料驗證

單元目標:練習用 VBA 建立下拉選單、數值 / 日期 / 長度 / 自訂公式驗證,打造不會輸錯的輸入介面。

操作檔案:07_DataValidation.bas

準備資料

本單元在新工作表直接執行即可,巨集會自動建立選項與驗證範圍(B~J 欄)。建議先另存空白檔案再練習。

案例操作

操作 1:CreateDropdownList

建立固定選項的下拉選單。

  1. 游標停在 CreateDropdownList 內按 F5。
  2. 點選 C2 儲存格,右側會出現下拉箭頭,從中選擇縣市(台北、台中、台南、高雄、新北)。
  3. 在 C2 直接輸入不存在的值,例如「台南市」,按 Enter。
預期結果:下拉選單建立於 C2:C100。輸入非法縣市時會跳出「輸入錯誤」的錯誤訊息並阻止輸入;從下拉選擇則可正常輸入。

操作 2:CreateNumberValidation + CreateDecimalValidation + CreateDateValidation + CreateStringLengthValidation + CreateCustomValidation

依序建立數值 / 小數 / 日期 / 長度 / 自訂公式驗證並測試。

  1. 依序把游標停在每個巨集內按 F5(不用先手動輸入資料)。
  2. 測試 E 欄:輸入 150 會被擋(限 1~100 整數);輸入 50 可通過。
  3. 測試 F 欄:輸入 1.5 會被擋(限 0~1 小數,顯示為百分比)。
  4. 測試 G 欄:輸入 2023/12/31 會被擋(限 2024/01/01 ~ 2025/12/31)。
  5. 測試 H 欄:輸入 12345 會被擋(限 8 個字元)。
  6. 測試 I 欄:輸入 3 會被擋(限偶數,自訂公式 ISEVEN)。
預期結果:每個欄位各自套用不同的驗證規則:E 整數範圍、F 小數百分比、G 日期範圍、H 字串長度、I 偶數限制。輸入不合規格一律跳出錯誤訊息。

操作 3:CreateUniqueValidation

防止同欄重複值。

  1. 按 F5 執行 CreateUniqueValidation。
  2. 在 J2 輸入 A001,再於 J3 輸入 A001。
預期結果:J2 正常輸入,J3 輸入相同值時跳出「重複值」錯誤,確保單號 / 身分證字號不重複。

操作 4:CreateFormWithValidation

建立完整的員工資料輸入表單。

  1. 按 F5 執行 CreateFormWithValidation(此巨集會清空 A1:F30,請在空白工作表執行)。
  2. 依序測試 B4 姓名長度、B5 部門下拉、B6 職稱下拉、B7 日期、B8 薪資範圍(22,000 ~ 200,000)、B9 評分(0~100 整數)、B10 在職是/否、B11 等級 A/B/C/D。
預期結果:一次產生含 8 項驗證的員工表單:A 欄為欄位名稱,B 欄為輸入區,每個輸入區都有對應的驗證或下拉選單,輸入錯誤會被擋下。

操作 5:SetupDynamicDropdown + ShowAllValidations + ClearAllValidations

動態下拉選單與驗證管理。

  1. 按 F5 執行 SetupDynamicDropdown。
  2. 切回工作表,在 Y 欄「部門」表格最下方新增一格輸入「法務部」。
  3. 點選 C2 儲存格,展開下拉選單確認「法務部」已自動出現。
  4. 按 F5 執行 ShowAllValidations 查看規則清單;最後可執行 ClearAllValidations 清掉全部規則。
預期結果:部門下拉選單引用 Excel 表格,新增部門即自動擴展選項,不需改任何公式。ShowAllValidations 會列出所有儲存格與規則類型,ClearAllValidations 可一次清除。
資料驗證 完整程式碼(參考用)
' ============================================================
' Excel 資料驗證(Data Validation)VBA 範例
' 功能:用 VBA 程式化建立/管理資料驗證
' ============================================================

Option Explicit

' ============================================================
' 一、下拉選單驗證
' ============================================================

Sub CreateDropdownList()
    ' 建立下拉選單:C2:C100 只能選「台北、台中、台南、高雄、新北」
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' 清除舊的資料驗證
    On Error Resume Next
    ws.Range("C2:C100").Validation.Delete
    On Error GoTo 0
    
    ' 建立下拉選單
    With ws.Range("C2:C100").Validation
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="台北,台中,台南,高雄,新北"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "請選擇縣市"
        .ErrorTitle = "輸入錯誤"
        .ErrorMessage = "請從下拉選單中選擇縣市!"
    End With
    
    ' 加入提示註解
    ws.Range("C1").Comment.Text Text:="請使用下拉選單選擇縣市"
    
    MsgBox "已建立下拉選單驗證!" & vbCrLf & _
           "範圍:C2:C100" & vbCrLf & _
           "選項:台北、台中、台南、高雄、新北", vbInformation
End Sub

Sub CreateDropdownFromRange()
    ' 從儲存格範圍建立下拉選單
    Dim ws As Worksheet
    Dim sourceRange As String
    
    Set ws = ActiveSheet
    
    ' 先建立選項清單(放在 Z 欄)
    Dim lastOptionRow As Long
    lastOptionRow = ws.Cells(ws.Rows.Count, "Z").End(xlUp).Row
    
    If lastOptionRow < 2 Then
        ' 如果 Z 欄沒有資料,自動建立選項
        ws.Range("Z1").Value = "產品類別"
        ws.Range("Z2").Value = "電子產品"
        ws.Range("Z3").Value = "食品"
        ws.Range("Z4").Value = "服飾"
        ws.Range("Z5").Value = "家居"
        ws.Range("Z6").Value = "書籍"
        ws.Range("Z7").Value = "運動用品"
        lastOptionRow = 7
    End If
    
    sourceRange = "Z2:Z" & lastOptionRow
    
    ' 清除舊驗證
    On Error Resume Next
    ws.Range("D2:D1000").Validation.Delete
    On Error GoTo 0
    
    ' 建立下拉選單(引用範圍)
    With ws.Range("D2:D1000").Validation
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="=" & sourceRange
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "產品類別"
        .ErrorTitle = "無效選項"
        .ErrorMessage = "請選擇有效的產品類別!"
    End With
    
    ' 隱藏 Z 欄
    ws.Columns("Z").Hidden = True
    
    MsgBox "已建立下拉選單!" & vbCrLf & _
           "選項來源:Z2:Z" & lastOptionRow & vbCrLf & _
           "套用範圍:D2:D1000", vbInformation
End Sub

' ============================================================
' 二、數值範圍驗證
' ============================================================

Sub CreateNumberValidation()
    ' 驗證 E 欄:必須是 1~100 之間的整數
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    On Error Resume Next
    ws.Range("E2:E500").Validation.Delete
    On Error GoTo 0
    
    With ws.Range("E2:E500").Validation
        .Add Type:=xlValidateWholeNumber, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="1", _
             Formula2:="100"
        .IgnoreBlank = True
        .InCellDropdown = False
        .InputTitle = "分數輸入"
        .ErrorTitle = "輸入錯誤"
        .ErrorMessage = "分數必須是 1~100 之間的整數!"
    End With
    
    MsgBox "已建立數值範圍驗證!" & vbCrLf & _
           "範圍:E2:E500" & vbCrLf & _
           "條件:1~100 的整數", vbInformation
End Sub

Sub CreateDecimalValidation()
    ' 驗證 F 欄:必須是 0.00~1.00 之間的小數(百分比)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    On Error Resume Next
    ws.Range("F2:F500").Validation.Delete
    On Error GoTo 0
    
    With ws.Range("F2:F500").Validation
        .Add Type:=xlValidateDecimal, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="0", _
             Formula2:="1"
        .IgnoreBlank = True
        .InCellDropdown = False
        .InputTitle = "百分比"
        .ErrorTitle = "輸入錯誤"
        .ErrorMessage = "請輸入 0~1 之間的小數(例如:0.85)"
    End With
    
    ' 設定格式為百分比
    ws.Range("F2:F500").NumberFormat = "0.00%"
    
    MsgBox "已建立小數範圍驗證!" & vbCrLf & _
           "範圍:F2:F500" & vbCrLf & _
           "條件:0~1 之間的小數", vbInformation
End Sub

' ============================================================
' 三、日期驗證
' ============================================================

Sub CreateDateValidation()
    ' 驗證 G 欄:必須是 2024/01/01 ~ 2025/12/31 之間的日期
    Dim ws As Worksheet
    Dim startDate As String
    Dim endDate As String
    
    Set ws = ActiveSheet
    
    startDate = "2024/01/01"
    endDate = "2025/12/31"
    
    On Error Resume Next
    ws.Range("G2:G500").Validation.Delete
    On Error GoTo 0
    
    With ws.Range("G2:G500").Validation
        .Add Type:=xlValidateDate, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="DATEVALUE(""" & startDate & """)", _
             Formula2:="DATEVALUE(""" & endDate & """)"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "日期選擇"
        .ErrorTitle = "日期錯誤"
        .ErrorMessage = "請輸入 " & startDate & " 至 " & endDate & " 之間的日期!"
    End With
    
    ws.Range("G2:G500").NumberFormat = "yyyy/mm/dd"
    
    MsgBox "已建立日期驗證!" & vbCrLf & _
           "範圍:G2:G500" & vbCrLf & _
           "條件:" & startDate & " ~ " & endDate, vbInformation
End Sub

' ============================================================
' 四、字串長度驗證
' ============================================================

Sub CreateStringLengthValidation()
    ' 驗證 H 欄:電話號碼,必須是 8 位數字
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    On Error Resume Next
    ws.Range("H2:H500").Validation.Delete
    On Error GoTo 0
    
    With ws.Range("H2:H500").Validation
        .Add Type:=xlValidateLength, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="8", _
             Formula2:="8"
        .IgnoreBlank = True
        .InCellDropdown = False
        .InputTitle = "電話號碼"
        .ErrorTitle="格式錯誤"
        .ErrorMessage = "電話號碼必須是 8 位數字!"
    End With
    
    MsgBox "已建立字串長度驗證!" & vbCrLf & _
           "範圍:H2:H500" & vbCrLf & _
           "條件:8 個字元", vbInformation
End Sub

' ============================================================
' 五、自訂公式驗證
' ============================================================

Sub CreateCustomValidation()
    ' 驗證 I 欄:只能輸入偶數
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    On Error Resume Next
    ws.Range("I2:I500").Validation.Delete
    On Error GoTo 0
    
    With ws.Range("I2:I500").Validation
        .Add Type:=xlValidateCustom, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="=ISEVEN(I2)"
        .IgnoreBlank = True
        .InCellDropdown = False
        .InputTitle = "偶數輸入"
        .ErrorTitle = "輸入錯誤"
        .ErrorMessage = "只能輸入偶數!"
    End With
    
    MsgBox "已建立自訂公式驗證!" & vbCrLf & _
           "範圍:I2:I500" & vbCrLf & _
           "條件:只能輸入偶數", vbInformation
End Sub

Sub CreateUniqueValidation()
    ' 驗證 J 欄:必須是唯一的(不能重複)
    Dim ws As Worksheet
    Dim lastRow As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    On Error Resume Next
    ws.Range("J2:J500").Validation.Delete
    On Error GoTo 0
    
    ' COUNTIF = 1 表示該值只出現一次(唯一)
    Dim formula As String
    formula = "=COUNTIF(J$2:J$" & lastRow & ",J2)=1"
    
    With ws.Range("J2:J500").Validation
        .Add Type:=xlValidateCustom, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:=formula
        .IgnoreBlank = True
        .InCellDropdown = False
        .InputTitle = "唯一值輸入"
        .ErrorTitle = "重複值"
        .ErrorMessage = "此值已存在,請輸入唯一的值!"
    End With
    
    MsgBox "已建立唯一值驗證!" & vbCrLf & _
           "範圍:J2:J500" & vbCrLf & _
           "條件:不能與同欄其他值重複", vbInformation
End Sub

' ============================================================
' 六、輸入提示與錯誤訊息
' ============================================================

Sub SetInputTips()
    ' 設定輸入提示(當儲存格被選取時顯示的提示文字)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    With ws.Range("B2").Validation
        .Add Type:=xlValidateInputOnly
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "姓名輸入提示"
        .InputMessage = "請輸入員工姓名,使用中文或英文。" & vbCrLf & _
                        "範例:張三 或 ZhangSan"
        .ShowInput = True
    End With
    
    ' 設定錯誤提示(輸入無效時顯示)
    With ws.Range("B2").Validation
        .ShowError = True
        .ErrorStyle = xlValidAlertStop      ' 停止(阻止輸入)
        .ErrorTitle = "輸入錯誤"
        .ErrorMessage = "姓名不能為空,也不能包含特殊字元!"
    End With
    
    MsgBox "已設定 B2 儲存格的輸入提示與錯誤訊息。", vbInformation
End Sub

' ============================================================
' 七、資料驗證管理工具
' ============================================================

Sub ShowAllValidations()
    ' 列出目前工作表所有的資料驗證規則
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim cell As Range
    Dim ruleCount As Long
    Dim msg As String
    
    ruleCount = 0
    msg = "=== 資料驗證規則總覽 ===" & vbCrLf & vbCrLf
    
    For Each cell In ws.UsedRange
        If cell.Validation.Type <> xlValidateInputOnly Then
            ruleCount = ruleCount + 1
            msg = msg & "儲存格:" & cell.Address & vbCrLf
            msg = msg & "  類型:" & GetValidationType(cell.Validation.Type) & vbCrLf
            msg = msg & "  規則:" & cell.Validation.Formula1 & vbCrLf
            msg = msg & "  標題:" & cell.Validation.InputTitle & vbCrLf
            msg = msg & "------------------" & vbCrLf
        End If
    Next cell
    
    If ruleCount = 0 Then
        msg = msg & "目前工作表沒有設定資料驗證規則。"
    Else
        msg = msg & vbCrLf & "共 " & ruleCount & " 個驗證規則。"
    End If
    
    MsgBox msg, vbInformation, "資料驗證總覽"
End Sub

Sub ClearAllValidations()
    ' 清除整個工作表的所有資料驗證
    If MsgBox("確定要清除整個工作表的所有資料驗證規則嗎?", _
              vbQuestion + vbYesNo, "確認") = vbYes Then
        ActiveSheet.Cells.Validation.Delete
        MsgBox "已清除所有資料驗證規則。", vbInformation
    End If
End Sub

Sub ClearValidationRange()
    ' 清除指定範圍的資料驗證
    Dim rng As Range
    Dim addr As String
    
    addr = InputBox("請輸入要清除驗證的範圍(例如:A2:C100):", "清除驗證")
    If addr = "" Then Exit Sub
    
    On Error Resume Next
    Set rng = ActiveSheet.Range(addr)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "範圍無效!"
        Exit Sub
    End If
    
    rng.Validation.Delete
    MsgBox "已清除 " & addr & " 的資料驗證。", vbInformation
End Sub

' ============================================================
' 八、動態下拉選單(隨選項變更自動更新)
' ============================================================

Sub SetupDynamicDropdown()
    ' 建立動態下拉選單(使用 Excel 表格)
    Dim ws As Worksheet
    Dim listRange As Range
    Dim listHeaderRow As Long
    Dim listLastRow As Long
    
    Set ws = ActiveSheet
    
    ' 清除舊驗證
    On Error Resume Next
    ws.Range("C2:C1000").Validation.Delete
    On Error GoTo 0
    
    ' 檢查是否已有選項清單
    listLastRow = ws.Cells(ws.Rows.Count, "Y").End(xlUp).Row
    
    If listLastRow < 2 Then
        ' 自動建立選項
        ws.Range("Y1").Value = "部門"
        ws.Range("Y2").Value = "管理部"
        ws.Range("Y3").Value = "技術部"
        ws.Range("Y4").Value = "業務部"
        ws.Range("Y5").Value = "財務部"
        ws.Range("Y6").Value = "人資部"
        listLastRow = 6
    End If
    
    ' 將選項轉為 Excel 表格(自動擴展)
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = ws.ListObjects("部門清單")
    On Error GoTo 0
    
    If tbl Is Nothing Then
        Set tbl = ws.ListObjects.Add(xlSrcRange, _
                                     ws.Range("Y1:Y" & listLastRow), , xlYes)
        tbl.Name = "部門清單"
    End If
    
    ' 建立下拉選單(引用表格欄位)
    With ws.Range("C2:C1000").Validation
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="=部門清單[部門]"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "選擇部門"
        .ErrorTitle = "選擇錯誤"
        .ErrorMessage = "請從下拉選單選擇部門!"
    End With
    
    ' 隱藏 Y 欄
    ws.Columns("Y").Hidden = True
    
    MsgBox "已建立動態下拉選單!" & vbCrLf & _
           "新增選項只需加到表格即可自動擴展。", vbInformation
End Sub

' ============================================================
' 九、資料驗證 + 條件語法自動套用
' ============================================================

Sub CreateFormWithValidation()
    ' 建立含資料驗證的表單
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' 清除舊內容
    ws.Range("A1:F30").Clear
    
    ' 建立表單標題
    ws.Range("A1").Value = "員工資料表單"
    With ws.Range("A1:F1")
        .Merge
        .Font.Size = 14
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    ' 欄位設定
    Dim fields As Variant
    Dim types As Variant
    Dim formulas As Variant
    Dim i As Long
    
    fields = Array("欄位", "輸入", "", "驗證條件", "說明", "")
    types = Array("text", "text", "", "text", "text", "")
    
    ' 基本資料
    ws.Range("A3").Value = "員工編號"
    ws.Range("A4").Value = "姓名"
    ws.Range("A5").Value = "部門"
    ws.Range("A6").Value = "職稱"
    ws.Range("A7").Value = "入職日期"
    ws.Range("A8").Value = "基本薪資"
    ws.Range("A9").Value = "績效評分"
    ws.Range("A10").Value = "是否在職"
    ws.Range("A11").Value = "員工等級"
    
    ' 驗證設定
    With ws.Range("B4").Validation
        .Add Type:=xlValidateLength, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="2", Formula2:="20"
        .InputTitle = "姓名"
        .ErrorMessage = "姓名至少 2 個字元!"
    End With
    
    With ws.Range("B5").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="管理部,技術部,業務部,財務部,人資部,行銷部"
        .InCellDropdown = True
        .InputTitle = "部門"
        .ErrorMessage = "請選擇部門!"
    End With
    
    With ws.Range("B6").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="工程師,高级工程师,經理,副理,專員,助理專員"
        .InCellDropdown = True
        .InputTitle = "職稱"
        .ErrorMessage = "請選擇職稱!"
    End With
    
    With ws.Range("B7").Validation
        .Add Type:=xlValidateDate, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="DATEVALUE(""2000/01/01"")", _
             Formula2:="DATEVALUE(""2025/12/31"")"
        .InputTitle = "日期"
        .ErrorMessage = "請輸入有效日期!"
    End With
    ws.Range("B7").NumberFormat = "yyyy/mm/dd"
    
    With ws.Range("B8").Validation
        .Add Type:=xlValidateDecimal, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="22000", Formula2:="200000"
        .InputTitle = "薪資"
        .ErrorMessage = "薪資必須在 22,000~200,000 之間!"
    End With
    ws.Range("B8").NumberFormat = "#,##0"
    
    With ws.Range("B9").Validation
        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="0", Formula2:="100"
        .InputTitle = "評分"
        .ErrorMessage = "評分必須是 0~100 的整數!"
    End With
    
    With ws.Range("B10").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="是,否"
        .InCellDropdown = True
        .InputTitle = "在職狀態"
        .ErrorMessage = "請選擇「是」或「否」!"
    End With
    
    With ws.Range("B11").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="A,B,C,D"
        .InCellDropdown = True
        .InputTitle = "等級"
        .ErrorMessage = "等級只能是 A/B/C/D!"
    End With
    
    ' 設定格式
    ws.Range("B3:E3").Value = Array("欄位", "輸入欄位", "", "驗證條件")
    With ws.Range("A3:F3")
        .Font.Bold = True
        .Interior.Color = RGB(200, 200, 200)
    End With
    ws.Range("A3:F11").Borders.LineStyle = xlContinuous
    
    MsgBox "表單建立完成!含 8 項資料驗證規則。", vbInformation
End Sub

' ============================================================
' 輔助函數
' ============================================================

Function GetValidationType(typeNum As Long) As String
    Select Case typeNum
        Case xlValidateInputOnly: GetValidationType = "輸入提示"
        Case xlValidateWholeNumber: GetValidationType = "整數"
        Case xlValidateDecimal: GetValidationType = "小數"
        Case xlValidateDate: GetValidationType = "日期"
        Case xlValidateTime: GetValidationType = "時間"
        Case xlValidateTextLength: GetValidationType = "字串長度"
        Case xlValidateList: GetValidationType = "下拉選單"
        Case xlValidateCustom: GetValidationType = "自訂公式"
        Case Else: GetValidationType = "未知(" & typeNum & ")"
    End Select
End Function
CreateFormWithValidation 會覆蓋 A1:F30 的內容;CreateDropdownFromRange 與 SetupDynamicDropdown 會在 Z、Y 欄建立選項清單並隱藏該欄。
日誌

08 日誌系統

單元目標:練習把程式執行過程、股價、API 呼叫與工作表變更記錄下來,並自動清理舊日誌。

操作檔案:08_LoggingSystem.bas

準備資料

本單元不需準備資料表格。文字日誌檔會寫在工作簿「同一個資料夾」中,檔名為 log_日期.txt。

案例操作

操作 1:LogSystemInfo

把系統環境寫入日誌檔。

  1. 游標停在 LogSystemInfo 內按 F5。
預期結果:跳出訊息告知日誌路徑;在工作簿旁產生 log_日期.txt,內容包含 Excel 版本、作業系統、工作簿路徑、使用者、電腦名稱與執行時間,同時輸出到立即視窗(Ctrl+G 可查看)。

操作 2:LogStockPrice

把每日股價記錄到工作表與日誌檔。

  1. 按 F5 執行 LogStockPrice。
  2. 輸入股票代號 2330.TW 後按確定(需網路)。
預期結果:建立「股價日誌」工作表(若已存在則直接附加),新增一筆 時間 / 代號 / 名稱 / 收盤價 / 漲跌 / 漲幅% 紀錄並自動上色,同時寫入文字日誌檔,跳出「股價已記錄至「股價日誌」工作表。」。

操作 3:LogApiCall + ShowApiLogSummary

追蹤 API 呼叫品質。

  1. 按 F5 執行 LogApiCall,輸入股票代號 2330.TW,呼叫類型輸入「即時股價」。
  2. 再按 F5 執行 ShowApiLogSummary。
預期結果:「API 日誌」工作表新增一筆 成功 / 耗時(ms) 紀錄並寫入文字檔。ShowApiLogSummary 顯示統計:總呼叫次數、成功、失敗、平均耗時、總耗時。

操作 4:EnableChangeTracking

記錄工作表的變更。

  1. 按 F5 執行 EnableChangeTracking(會記錄目前整張工作表的初始狀態)。
  2. 切回工作表,隨意修改任一儲存格的內容。
  3. 再回到 VBA,按 F5 執行 ShowPriceLog 以外的檢視方式,直接點開「變更日誌」工作表查看。
預期結果:建立「變更日誌」工作表:先記錄每格初始值;修改儲存格後會在該工作表留下 變更時間 / 工作表 / 儲存格 / 舊值 / 新值 的紀錄。

操作 5:StockAnalysisWithLog

完整的「帶日誌股價分析」流程示範。

  1. 按 F5 執行 StockAnalysisWithLog(需網路,且需 32 位元 Office 才能解析 JSON)。
  2. 輸入股票代號 2330.TW 後按確定。
預期結果:逐步寫入 5 個階段日誌(取得報價 → 解析 JSON → 提取資料 → 寫入工作表 → 完成),建立「分析結果」工作表,最後跳出「股價分析完成!… 耗時 … 秒」並顯示日誌路徑。

操作 6:ClearOldLogs + ShowLogFiles

清理與檢視日誌。

  1. 按 F5 執行 ShowLogFiles 查看目前有哪些 log_*.txt。
  2. 按 F5 執行 ClearOldLogs。
預期結果:ShowLogFiles 列出所有日誌檔(含大小與修改時間);ClearOldLogs 刪除 30 天前的 log_*.txt,並顯示清除數量。
日誌系統 完整程式碼(參考用)
' ============================================================
' VBA 日誌系統 (Log System)
' 功能:通用日誌記錄工具,支援寫入日誌檔、工作表、即時監控
' ============================================================

Option Explicit

' ============================================================
' 一、基礎日誌寫入(文字檔)
' ============================================================

Sub WriteLog(text As String, Optional logLevel As String = "INFO")
    ' 將訊息寫入日誌檔案
    Dim logFile As String
    Dim fso As Object
    Dim ts As Object
    Dim timestamp As String
    
    timestamp = Format(Now, "yyyy-mm-dd hh:nn:ss")
    logFile = ThisWorkbook.Path & "\log_" & Format(Date, "yyyy-mm-dd") & ".txt"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpenTextFile(logFile, 8, True)  ' 8 = AppendMode
    
    ts.WriteLine "[" & timestamp & "] [" & logLevel & "] " & text
    ts.Close
    
    ' 同時輸出到立即視窗
    Debug.Print "[" & timestamp & "] [" & logLevel & "] " & text
End Sub

Sub LogExample()
    ' 日誌使用範例
    WriteLog "程式開始執行", "START"
    WriteLog "正在取得股票資料...", "INFO"
    
    On Error GoTo ErrorHandler
    ' ... 您的程式碼 ...
    WriteLog "股票資料取得完成", "INFO"
    Exit Sub
    
ErrorHandler:
    WriteLog "發生錯誤:" & Err.Description, "ERROR"
    WriteLog "錯誤代碼:" & Err.Number, "ERROR"
End Sub

' ============================================================
' 二、股價日誌(記錄每日股價變化)
' ============================================================

Sub LogStockPrice()
    ' 將股價資料寫入日誌工作表
    Dim symbol As String
    Dim url As String
    Dim http As Object
    Dim jsonText As String
    Dim json As Object
    Dim meta As Object
    
    symbol = InputBox("請輸入股票代號:", "股價日誌", "2330.TW")
    If symbol = "" Then Exit Sub
    
    ' 取得股價
    url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    http.Send
    jsonText = http.responseText
    
    Set json = JsonToObject(jsonText)
    Set meta = json("chart")("meta")
    
    Dim currentPrice As Double
    currentPrice = CDbl(meta("regularMarketPrice"))
    
    ' 建立日誌工作表
    Dim wsLog As Worksheet
    On Error Resume Next
    Set wsLog = ThisWorkbook.Worksheets("股價日誌")
    On Error GoTo 0
    
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Worksheets.Add
        wsLog.Name = "股價日誌"
        wsLog.Range("A1:F1").Value = Array("時間", "股票代號", "股票名稱", "收盤價", "漲跌", "漲幅%")
        With wsLog.Range("A1:F1")
            .Font.Bold = True
            .Interior.Color = RGB(0, 102, 153)
            .Font.Color = vbWhite
        End With
    End If
    
    Dim lastRow As Long
    lastRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).Row + 1
    
    Dim prevClose As Double
    prevClose = CDbl(meta("previousClose"))
    
    wsLog.Cells(lastRow, 1).Value = Now
    wsLog.Cells(lastRow, 1).NumberFormat = "yyyy-mm-dd hh:nn:ss"
    wsLog.Cells(lastRow, 2).Value = meta("symbol")
    wsLog.Cells(lastRow, 3).Value = meta("shortName")
    wsLog.Cells(lastRow, 4).Value = currentPrice
    wsLog.Cells(lastRow, 4).NumberFormat = "#,##0.00"
    wsLog.Cells(lastRow, 5).Value = currentPrice - prevClose
    wsLog.Cells(lastRow, 5).NumberFormat = "+#,##0.00;-#,##0.00"
    wsLog.Cells(lastRow, 6).Value = ((currentPrice - prevClose) / prevClose) * 100
    wsLog.Cells(lastRow, 6).NumberFormat = "+0.00;-0.00"
    
    ' 漲跌顏色
    If currentPrice > prevClose Then
        wsLog.Cells(lastRow, 5).Font.Color = vbRed
        wsLog.Cells(lastRow, 6).Font.Color = vbRed
    ElseIf currentPrice < prevClose Then
        wsLog.Cells(lastRow, 5).Font.Color = vbGreen
        wsLog.Cells(lastRow, 6).Font.Color = vbGreen
    End If
    
    wsLog.Columns.AutoFit
    
    ' 也寫入日誌檔
    WriteLog "股價紀錄:" & meta("symbol") & " 收盤價 " & currentPrice & _
             " (" & Format((currentPrice - prevClose) / prevClose * 100, "0.00") & "%)", "PRICE"
    
    MsgBox "股價已記錄至「股價日誌」工作表。", vbInformation
End Sub

Sub ShowPriceLog()
    ' 顯示股價日誌
    On Error Resume Next
    Dim wsLog As Worksheet
    Set wsLog = ThisWorkbook.Worksheets("股價日誌")
    On Error GoTo 0
    
    If wsLog Is Nothing Then
        MsgBox "尚未有股價日誌資料。", vbExclamation
        Exit Sub
    End If
    
    MsgBox "股價日誌共有 " & (wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).Row - 1) & " 筆紀錄。", vbInformation
End Sub

' ============================================================
' 三、資料變更追蹤日誌
' ============================================================

Sub EnableChangeTracking()
    ' 啟用工作表變更追蹤(將變更記錄到日誌工作表)
    Dim wsSource As Worksheet
    Dim wsTrack As Worksheet
    Dim lastRow As Long
    
    Set wsSource = ActiveSheet
    
    ' 建立追蹤工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("變更日誌").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsTrack = ThisWorkbook.Worksheets.Add
    wsTrack.Name = "變更日誌"
    
    wsTrack.Range("A1:E1").Value = Array("變更時間", "工作表", "儲存格", "舊值", "新值")
    With wsTrack.Range("A1:E1")
        .Font.Bold = True
        .Interior.Color = RGB(70, 130, 180)
        .Font.Color = vbWhite
    End With
    
    ' 記錄初始狀態
    lastRow = 2
    Dim cell As Range
    For Each cell In wsSource.UsedRange
        If cell.Value <> "" Then
            wsTrack.Cells(lastRow, 1).Value = Now
            wsTrack.Cells(lastRow, 2).Value = wsSource.Name
            wsTrack.Cells(lastRow, 3).Value = cell.Address
            wsTrack.Cells(lastRow, 4).Value = "[初始]"
            wsTrack.Cells(lastRow, 5).Value = cell.Value
            lastRow = lastRow + 1
        End If
    Next cell
    
    wsTrack.Columns.AutoFit
    
    MsgBox "變更追蹤已啟用!" & vbCrLf & _
           "所有資料修改將記錄到「變更日誌」工作表。", vbInformation
End Sub

' ============================================================
' 四、API 呼叫日誌(追蹤 API 請求)
' ============================================================

Sub LogApiCall()
    ' 記錄 API 呼叫歷史
    Dim symbol As String
    Dim callType As String
    Dim wsApiLog As Worksheet
    Dim lastRow As Long
    Dim startTime As Double
    Dim endTime As Double
    Dim duration As Double
    
    symbol = InputBox("請輸入股票代號:", "API 日誌", "2330.TW")
    If symbol = "" Then Exit Sub
    
    callType = InputBox("呼叫類型:", "API 日誌", "即時股價")
    If callType = "" Then callType = "未分類"
    
    ' 建立 API 日誌工作表
    On Error Resume Next
    Set wsApiLog = ThisWorkbook.Worksheets("API 日誌")
    On Error GoTo 0
    
    If wsApiLog Is Nothing Then
        Set wsApiLog = ThisWorkbook.Worksheets.Add
        wsApiLog.Name = "API 日誌"
        wsApiLog.Range("A1:F1").Value = Array("時間", "股票代號", "呼叫類型", "狀態", "耗時(ms)", "備註")
        With wsApiLog.Range("A1:F1")
            .Font.Bold = True
            .Interior.Color = RGB(0, 128, 0)
            .Font.Color = vbWhite
        End With
    End If
    
    startTime = Timer
    
    ' 模擬 API 呼叫
    Dim http As Object
    Dim url As String
    Dim success As Boolean
    Dim errorMsg As String
    
    url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    On Error Resume Next
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    http.Send
    success = (http.Status = 200)
    If Not success Then errorMsg = "HTTP " & http.Status
    On Error GoTo 0
    
    endTime = Timer
    duration = (endTime - startTime) * 1000
    
    lastRow = wsApiLog.Cells(wsApiLog.Rows.Count, 1).End(xlUp).Row + 1
    
    wsApiLog.Cells(lastRow, 1).Value = Now
    wsApiLog.Cells(lastRow, 2).Value = symbol
    wsApiLog.Cells(lastRow, 3).Value = callType
    wsApiLog.Cells(lastRow, 4).Value = IIf(success, "成功", "失敗:" & errorMsg)
    wsApiLog.Cells(lastRow, 5).Value = Round(duration, 2)
    wsApiLog.Cells(lastRow, 6).Value = IIf(success, "OK", errorMsg)
    
    ' 狀態顏色
    If success Then
        wsApiLog.Cells(lastRow, 4).Font.Color = vbGreen
    Else
        wsApiLog.Cells(lastRow, 4).Font.Color = vbRed
    End If
    
    wsApiLog.Columns.AutoFit
    
    ' 寫入日誌檔
    WriteLog "API 呼叫:" & symbol & " (" & callType & ") - " & _
             IIf(success, "成功", "失敗") & " (" & Round(duration, 2) & "ms)", _
             IIf(success, "INFO", "ERROR")
End Sub

Sub ShowApiLogSummary()
    ' 顯示 API 日誌統計
    On Error Resume Next
    Dim wsApiLog As Worksheet
    Set wsApiLog = ThisWorkbook.Worksheets("API 日誌")
    On Error GoTo 0
    On Error GoTo 0
    
    If wsApiLog Is Nothing Then
        MsgBox "尚未有 API 日誌資料。", vbExclamation
        Exit Sub
    End If
    
    Dim lastRow As Long
    lastRow = wsApiLog.Cells(wsApiLog.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "尚未有 API 呼叫紀錄。", vbExclamation
        Exit Sub
    End If
    
    Dim totalCount As Long
    Dim successCount As Long
    Dim failCount As Long
    Dim totalTime As Double
    Dim avgTime As Double
    Dim i As Long
    
    totalCount = lastRow - 1
    successCount = 0
    failCount = 0
    totalTime = 0
    
    For i = 2 To lastRow
        If InStr(CStr(wsApiLog.Cells(i, 4).Value), "成功") > 0 Then
            successCount = successCount + 1
        Else
            failCount = failCount + 1
        End If
        totalTime = totalTime + CDbl(wsApiLog.Cells(i, 5).Value)
    Next i
    
    If totalCount > 0 Then
        avgTime = totalTime / totalCount
    End If
    
    Dim msg As String
    msg = "=== API 日誌統計 ===" & vbCrLf & vbCrLf
    msg = msg & "總呼叫次數:" & totalCount & vbCrLf
    msg = msg & "成功:" & successCount & " 次" & vbCrLf
    msg = msg & "失敗:" & failCount & " 次" & vbCrLf
    msg = msg & "平均耗時:" & Format(avgTime, "0.00") & " ms" & vbCrLf
    msg = msg & "總耗時:" & Format(totalTime, "0.00") & " ms" & vbCrLf
    msg = msg & vbCrLf & "資料來源:「API 日誌」工作表"
    
    MsgBox msg, vbInformation
End Sub

' ============================================================
' 五、系統操作日誌
' ============================================================

Sub LogSystemInfo()
    ' 記錄系統環境資訊
    Dim msg As String
    
    msg = "=== 系統環境資訊 ===" & vbCrLf
    msg = msg & "Excel 版本:" & Application.Version & vbCrLf
    msg = msg & "作業系統:" & Application.OperatingSystem & vbCrLf
    msg = msg & "工作簿:" & ThisWorkbook.Name & vbCrLf
    msg = msg = "工作簿路徑:" & ThisWorkbook.Path & vbCrLf
    msg = msg & "使用者:" & Environ("username") & vbCrLf
    msg = msg & "電腦名稱:" & Environ("computername") & vbCrLf
    msg = msg & "執行時間:" & Now & vbCrLf
    
    WriteLog msg, "SYSTEM"
    
    MsgBox "系統資訊已寫入日誌檔案。" & vbCrLf & _
           "日誌路徑:" & ThisWorkbook.Path & "\log_" & Format(Date, "yyyy-mm-dd") & ".txt", vbInformation
End Sub

' ============================================================
' 六、程式執行流程日誌
' ============================================================

Sub StockAnalysisWithLog()
    ' 帶日誌的股價分析範例
    Dim symbol As String
    Dim startTime As Double
    Dim endTime As Double
    Dim steps As Long
    Dim totalSteps As Long
    
    startTime = Timer
    steps = 0
    totalSteps = 5
    
    WriteLog "========================================", "HEADER"
    WriteLog "股價分析程式開始執行", "START"
    
    symbol = InputBox("請輸入股票代號:", "股價分析", "2330.TW")
    If symbol = "" Then
        WriteLog "使用者取消操作", "CANCEL"
        WriteLog "程式終止", "END"
        Exit Sub
    End If
    
    ' Step 1: 取得即時股價
    steps = steps + 1
    WriteLog "[" & steps & "/" & totalSteps & "] 取得即時股價 - " & symbol, "STEP"
    
    Dim http As Object
    Dim url As String
    Dim jsonText As String
    
    url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    
    On Error Resume Next
    http.Send
    If Err.Number <> 0 Then
        WriteLog "API 呼叫失敗:" & Err.Description, "ERROR"
        WriteLog "程式執行失敗", "END"
        Exit Sub
    End If
    On Error GoTo 0
    
    jsonText = http.responseText
    WriteLog "API 回應長度:" & Len(jsonText) & " 字元", "INFO"
    
    ' Step 2: 解析 JSON
    steps = steps + 1
    WriteLog "[" & steps & "/" & totalSteps & "] 解析 JSON 資料", "STEP"
    
    Dim json As Object
    Set json = JsonToObject(jsonText)
    
    If json Is Nothing Then
        WriteLog "JSON 解析失敗", "ERROR"
        WriteLog "程式執行失敗", "END"
        Exit Sub
    End If
    WriteLog "JSON 解析成功", "INFO"
    
    ' Step 3: 提取資料
    steps = steps + 1
    WriteLog "[" & steps & "/" & totalSteps & "] 提取股價資料", "STEP"
    
    Dim meta As Object
    Set meta = json("chart")("meta")
    
    Dim currentPrice As Double
    Dim previousClose As Double
    Dim changePercent As Double
    
    currentPrice = CDbl(meta("regularMarketPrice"))
    previousClose = CDbl(meta("previousClose"))
    changePercent = ((currentPrice - previousClose) / previousClose) * 100
    
    WriteLog "收盤價:" & currentPrice & " | 漲跌幅:" & changePercent & "%", "DATA"
    
    ' Step 4: 寫入工作表
    steps = steps + 1
    WriteLog "[" & steps & "/" & totalSteps & "] 寫入工作表", "STEP"
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("分析結果").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets.Add
    ws.Name = "分析結果"
    
    ws.Range("A1").Value = "股票分析報告"
    ws.Range("A1").Font.Size = 14
    ws.Range("A1").Font.Bold = True
    ws.Range("A1").Font.Color = RGB(0, 102, 153)
    
    ws.Range("A3").Value = "股票代號"
    ws.Range("B3").Value = symbol
    ws.Range("A4").Value = "股票名稱"
    ws.Range("B4").Value = meta("shortName")
    ws.Range("A5").Value = "收盤價"
    ws.Range("B5").Value = currentPrice
    ws.Range("A6").Value = "漲跌幅"
    ws.Range("B6").Value = changePercent
    ws.Range("A7").Value = "分析時間"
    ws.Range("B7").Value = Now
    
    WriteLog "工作表建立完成", "INFO"
    
    ' Step 5: 完成
    steps = steps + 1
    WriteLog "[" & steps & "/" & totalSteps & "] 分析完成", "STEP"
    
    endTime = Timer
    Dim duration As Double
    duration = endTime - startTime
    
    WriteLog "總耗時:" & Round(duration, 2) & " 秒", "INFO"
    WriteLog "程式執行成功", "END"
    WriteLog "========================================", "HEADER"
    
    MsgBox "股價分析完成!" & vbCrLf & _
           "耗時:" & Round(duration, 2) & " 秒" & vbCrLf & _
           "結果已寫入「分析結果」工作表" & vbCrLf & _
           "日誌已寫入:" & ThisWorkbook.Path & "\log_" & Format(Date, "yyyy-mm-dd") & ".txt", vbInformation
End Sub

' ============================================================
' 七、日誌清理工具
' ============================================================

Sub ClearOldLogs()
    ' 清除 30 天前的日誌檔案
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim logFolder As String
    Dim deletedCount As Long
    Dim cutoffDate As Date
    
    cutoffDate = DateAdd("d", -30, Date)
    logFolder = ThisWorkbook.Path & ""
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(logFolder) Then
        MsgBox "日誌資料夾不存在。", vbExclamation
        Exit Sub
    End If
    
    Set folder = fso.GetFolder(logFolder)
    
    For Each file In folder.Files
        If LCase(Right(file.Name, 4)) = ".txt" And LCase(Left(file.Name, 4)) = "log_" Then
            If file.DateCreated < cutoffDate Or file.DateLastModified < cutoffDate Then
                file.Delete
                deletedCount = deletedCount + 1
            End If
        End If
    Next file
    
    MsgBox "已清除 " & deletedCount & " 個超過 30 天的日誌檔案。", vbInformation
End Sub

Sub ShowLogFiles()
    ' 列出所有日誌檔案
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim msg As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(ThisWorkbook.Path)
    
    msg = "=== 日誌檔案列表 ===" & vbCrLf & vbCrLf
    Dim found As Boolean
    found = False
    
    For Each file In folder.Files
        If LCase(Right(file.Name, 4)) = ".txt" And LCase(Left(file.Name, 4)) = "log_" Then
            msg = msg & file.Name & vbCrLf
            msg = msg & "  大小:" & Round(file.Size / 1024, 2) & " KB" & vbCrLf
            msg = msg & "  修改時間:" & file.DateLastModified & vbCrLf
            msg = msg & vbCrLf
            found = True
        End If
    Next file
    
    If Not found Then
        msg = msg & "尚未有日誌檔案。"
    Else
        msg = msg & "共 " & folder.Files.Count & " 個檔案。"
    End If
    
    MsgBox msg, vbInformation, "日誌檔案"
End Sub
日誌檔寫在 ThisWorkbook.Path(工作簿所在資料夾);WriteLog 亦可直接從立即視窗呼叫,例如:WriteLog "測試訊息", "INFO"。
工具庫

Json JSON 解析器

單元目標:練習用 JsonParse / JsonToObject / JsonGet 解析 JSON,以及使用內建的股價查詢巨集。

操作檔案:JsonParser.bas

準備資料

本單元不需準備資料表格。先確認使用 32 位元 Office(JSON 解析依賴 MSScriptControl.ScriptControl,64 位元會失敗)。

案例操作

操作 1:GetRealtimePriceFull

用現成巨集驗證 JSON 解析(即時股價)。

  1. 在 JsonParser 模組中,游標停在 GetRealtimePriceFull 內按 F5。
  2. 輸入 2330.TW 後按確定(需網路)。
預期結果:跳出完整報價訊息框,代表整段 JSON 已成功解析並取出欄位值。這是本工具集唯一能正常查即時報價的現成巨集。

操作 2:GetMultiplePricesFull

多股行情寫入工作表。

  1. 按 F5 執行 GetMultiplePricesFull。
  2. 輸入 2330.TW,2454.TW,AAPL 後按確定。
預期結果:建立「Yahoo股價」工作表,多支股票的 11 個欄位(代號、名稱、價格、開高低、成交量、漲跌、漲幅、貨幣),漲紅跌綠,並顯示成功筆數。

操作 3:JsonToObject + JsonGet 立即視窗測試

在立即視窗手動驗證 JSON 函數。

  1. 按 Ctrl+G 打開立即視窗,貼上下列指令後按 Enter:
  2. Dim j As Object: Set j = JsonToObject("{\"name\":\"張三\",\"score\":95}")
  3. 再貼上 ? JsonGet(j, "name") 按 Enter 查看輸出。
預期結果:立即視窗會輸出「張三」。JsonGet 支援多層巢狀,例如 JsonGet(json, "chart", "meta", "regularMarketPrice") 可取出 Yahoo 報價欄位。
JSON 解析器 完整程式碼(參考用)
' ============================================================
' MS JSON Parser - 為 VBA 加入 JSON 解析能力
' 使用方式:匯入此 .bas 檔案後即可使用 JsonParse 函數
' ============================================================

Option Explicit

' ============================================================
' JSON 解析器主函數
' ============================================================

Public Function JsonParse(jsonText As String) As Object
    On Error GoTo ErrorHandler
    
    Dim jScript As Object
    Set jScript = CreateObject("MSScriptControl.ScriptControl")
    jScript.Language = "JScript"
    
    ' 使用 JScript 的 eval 解析 JSON
    Dim code As String
    code = "eval('(" & jsonText & ")')"
    
    Set JsonParse = jScript.Eval(code)
    Exit Function

ErrorHandler:
    Set JsonParse = Nothing
End Function

' ============================================================
' 改良版:支援巢狀物件與陣列的 JSON 解析
' ============================================================

Public Function JsonToObject(jsonText As String) As Object
    On Error GoTo ErrHandler
    
    Dim json As Object
    Set json = JsonParse(jsonText)
    Set JsonToObject = json
    Exit Function

ErrHandler:
    Set JsonToObject = Nothing
End Function

' ============================================================
' 從 JSON 中提取指定欄位的值
' ============================================================

Public Function JsonGet(obj As Object, param1 As Variant, Optional param2 As Variant, _
                        Optional param3 As Variant, Optional param4 As Variant) As Variant
    ' 用法:
    ' JsonGet(json, "key")
    ' JsonGet(json, "key1", "key2")
    ' JsonGet(json, "key1", "key2", "key3")
    On Error GoTo ErrHandler
    
    Dim current As Object
    Set current = obj
    
    If IsMissing(param1) Then
        JsonGet = obj
        Exit Function
    End If
    
    If VarType(param1) = vbString Then
        Set current = current(param1)
    Else
        Set current = current(param1)
    End If
    
    If IsMissing(param2) Then
        Set JsonGet = current
        Exit Function
    End If
    
    If VarType(param2) = vbString Then
        Set current = current(param2)
    Else
        Set current = current(param2)
    End If
    
    If IsMissing(param3) Then
        Set JsonGet = current
        Exit Function
    End If
    
    If VarType(param3) = vbString Then
        Set current = current(param3)
    Else
        Set current = current(param3)
    End If
    
    If IsMissing(param4) Then
        Set JsonGet = current
        Exit Function
    End If
    
    If VarType(param4) = vbString Then
        Set JsonGet = current(param4)
    Else
        Set JsonGet = current(param4)
    End If
    Exit Function

ErrHandler:
    Set JsonGet = Nothing
End Function

' ============================================================
' 快速股價查詢(完整 JSON 解析版)
' ============================================================

Sub GetRealtimePriceFull()
    Dim symbol As String
    Dim url As String
    Dim http As Object
    Dim jsonText As String
    Dim json As Object
    Dim meta As Object
    
    symbol = InputBox("請輸入股票代號(例:2330.TW、AAPL、TSLA、MSFT):", "Yahoo Finance 股價")
    If symbol = "" Then Exit Sub
    
    url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36"
    http.Send
    
    jsonText = http.responseText
    
    ' 解析 JSON
    Set json = JsonToObject(jsonText)
    
    If json Is Nothing Then
        MsgBox "JSON 解析失敗,請檢查網路或股票代號。" & vbCrLf & "原始回應:" & Left(jsonText, 200), vbCritical
        Exit Sub
    End If
    
    ' 取得 meta 資料
    Dim chart As Object
    Set chart = json("chart")
    Set meta = chart("meta")
    
    ' 提取數據
    Dim currentPrice As Double
    Dim previousClose As Double
    Dim openPrice As Double
    Dim dayHigh As Double
    Dim dayLow As Double
    Dim volume As Long
    
    currentPrice = CDbl(meta("regularMarketPrice"))
    previousClose = CDbl(meta("previousClose"))
    
    On Error Resume Next
    openPrice = CDbl(meta("regularMarketOpen"))
    dayHigh = CDbl(meta("regularMarketDayHigh"))
    dayLow = CDbl(meta("regularMarketDayLow"))
    volume = CLng(meta("regularMarketVolume"))
    On Error GoTo 0
    
    Dim change As Double
    Dim changePercent As Double
    change = currentPrice - previousClose
    changePercent = (change / previousClose) * 100
    
    ' 顯示結果
    Dim msg As String
    msg = "===== " & meta("symbol") & " =====" & vbCrLf
    msg = msg & "股票名稱:" & meta("shortName") & vbCrLf
    msg = msg & "交易所:" & meta("exchangeName") & vbCrLf
    msg = msg & "貨幣:" & meta("currency") & vbCrLf
    msg = msg & vbCrLf & _
          "收盤價:" & Format(currentPrice, "#,##0.00") & vbCrLf & _
          "前日收盤:" & Format(previousClose, "#,##0.00") & vbCrLf & _
          "開盤價:" & Format(openPrice, "#,##0.00") & vbCrLf & _
          "最高:" & Format(dayHigh, "#,##0.00") & vbCrLf & _
          "最低:" & Format(dayLow, "#,##0.00") & vbCrLf & _
          "成交量:" & Format(volume, "#,##0") & vbCrLf & _
          vbCrLf & _
          "漲跌:" & Format(change, "+#,##0.00;-#,##0.00") & vbCrLf & _
          "漲跌幅:" & Format(changePercent, "+0.00%;-0.00%") & vbCrLf & _
          vbCrLf & _
          "查詢時間:" & Now
    
    MsgBox msg, vbInformation, "Yahoo Finance - 即時股價"
End Sub

' ============================================================
' 多股即時行情(完整 JSON 解析版)
' ============================================================

Sub GetMultiplePricesFull()
    Dim symbols As String
    Dim symbolList() As String
    Dim i As Long
    
    symbols = InputBox("請輸入股票代號,以逗號分隔:", "多股查詢", _
                       "2330.TW,2454.TW,2317.TW,AAPL,TSLA,MSFT,GOOGL")
    If symbols = "" Then Exit Sub
    
    symbolList = Split(symbols, ",")
    
    ' 建立工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Yahoo股價").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = "Yahoo股價"
    
    ' 標題
    ws.Range("A1:K1").Value = Array("股票代號", "名稱", "目前價", "前日收盤", _
                                     "開盤", "最高", "最低", "成交量", "漲跌", "漲幅%", "貨幣")
    
    With ws.Range("A1:K1")
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 153)
        .Font.Color = vbWhite
    End With
    
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP")
    Dim rowIdx As Long
    rowIdx = 2
    Dim successCount As Long
    
    For i = LBound(symbolList) To UBound(symbolList)
        Dim symbol As String
        symbol = Trim(symbolList(i))
        If symbol = "" Then GoTo NextSym
        
        Dim url As String
        url = "https://query1.finance.yahoo.com/v8/finance/chart/" & symbol
        
        http.Open "GET", url, False
        http.setRequestHeader "User-Agent", "Mozilla/5.0"
        http.Send
        
        Dim jsonText As String
        jsonText = http.responseText
        
        Dim json As Object
        Set json = JsonToObject(jsonText)
        
        If Not json Is Nothing Then
            Dim meta As Object
            Set meta = json("chart")("meta")
            
            ws.Cells(rowIdx, 1).Value = meta("symbol")
            ws.Cells(rowIdx, 2).Value = meta("shortName")
            ws.Cells(rowIdx, 3).Value = CDbl(meta("regularMarketPrice"))
            ws.Cells(rowIdx, 4).Value = CDbl(meta("previousClose"))
            ws.Cells(rowIdx, 5).Value = CDbl(meta("regularMarketOpen"))
            ws.Cells(rowIdx, 6).Value = CDbl(meta("regularMarketDayHigh"))
            ws.Cells(rowIdx, 7).Value = CDbl(meta("regularMarketDayLow"))
            ws.Cells(rowIdx, 8).Value = CLng(meta("regularMarketVolume"))
            ws.Cells(rowIdx, 11).Value = meta("currency")
            
            Dim chg As Double
            Dim chgPct As Double
            chg = CDbl(meta("regularMarketPrice")) - CDbl(meta("previousClose"))
            chgPct = (chg / CDbl(meta("previousClose"))) * 100
            
            ws.Cells(rowIdx, 9).Value = chg
            ws.Cells(rowIdx, 10).Value = chgPct
            
            ' 漲跌顏色
            If chg > 0 Then
                ws.Cells(rowIdx, 9).Font.Color = vbRed
                ws.Cells(rowIdx, 10).Font.Color = vbRed
            ElseIf chg < 0 Then
                ws.Cells(rowIdx, 9).Font.Color = vbGreen
                ws.Cells(rowIdx, 10).Font.Color = vbGreen
            End If
            
            successCount = successCount + 1
        Else
            ws.Cells(rowIdx, 1).Value = symbol
            ws.Cells(rowIdx, 3).Value = "取得失敗"
        End If
        
        rowIdx = rowIdx + 1

NextSym:
    Next i
    
    ' 格式設定
    ws.Columns.AutoFit
    ws.Columns("C:C").NumberFormat = "#,##0.00"
    ws.Columns("D:D").NumberFormat = "#,##0.00"
    ws.Columns("E:G").NumberFormat = "#,##0.00"
    ws.Columns("I:I").NumberFormat = "#,##0.00"
    ws.Columns("J:J").NumberFormat = "0.00"
    ws.Columns("K:K").NumberFormat = "#,##0"
    
    MsgBox "查詢完成!成功 " & successCount & " / " & UBound(symbolList) + 1 & " 支股票。", vbInformation
End Sub
JsonParser.bas 是 08 日誌系統的依賴(08 會呼叫 JsonToObject),請在 08 之前匯入。64 位元 Office 無法使用 ScriptControl,JSON 相關功能會直接報錯。

常見疑難排解

  1. 按 F5 沒反應:確認游標停在 Sub 名稱內(不是停在註解行),或先檢查是否有其他子程序選到。
  2. 巨集被封鎖:將工作簿所在資料夾加入信任位置,或開啟檔案時按「啟用內容」。
  3. 股價顯示「取得資料失敗」:確認有網路;即時報價請改用 JsonParser.bas 的 GetRealtimePriceFull。
  4. JSON 相關巨集報錯:MSScriptControl.ScriptControl 僅支援 32 位元 Office,請改用 32 位元版本。
  5. 工作表被刪掉:多數巨集會先刪除再重建同名工作表(統計報告、Yahoo股價、股價日誌…),操作前請先另存備份。
Excel VBA 資料分析工具集|案例操作教學(獨立 HTML,歡迎分享轉貼)
本文內容僅供學習參考,投資相關範例不構成任何投資建議。

etf:我很弱,才10%不到

20261005 紀錄,今年度透過自主開發的演算法,做個小紀錄,之前我的雷達紀錄關閉了,用低調的方式作紀錄,看懂就看懂,單純紀錄;目前美國雷達開始上線測試。 我與ai互動:  問:0050 我今年 9.5%年報酬 006208 9.98%年報酬,你覺得? ai: 我覺得成績不錯,...