Excel VBA 工具集｜案例操作教學
9 大模組、每個檔案一套獨立案例操作：先準備資料 → 照步驟按巨集 → 對照預期結果，跟著做就能上手。
目錄（點選跳到該檔案的操作教學）
開始之前：匯入與執行方式
- 開啟 Excel，按
Alt + F11進入 VBA 編輯器。 - 在專案總管右鍵工作簿 → 「匯入檔案」→ 選取要練習的那個
.bas檔。 - 執行方式：在 VBA 編輯器中，把游標放在子程序名稱
內，按F5執行。 - 若被擋下，請先「檔案 → 選項 → 信任中心 → 信任位置」加入此資料夾，或開啟檔案後按「啟用內容」。
- 匯入順序建議：
JsonParser.bas先匯入（08 日誌系統會用到它），其餘檔案彼此獨立、可單獨練習。 - 各單元的「準備資料」請照著打進工作表；欄位順序以該單元表格為準（每個範例的欄位假設不同）。
排序
01 資料排序
單元目標：練習用 VBA 將資料表排序：單欄排序（升序 / 降序）與多欄位排序。
操作檔案：
01_SortData.bas準備資料
在 Excel 新工作表第 1 列輸入表頭、第 2 列起輸入下列資料（此範例依巨集註解，第 2 欄為部門、第 3 欄為金額、第 5 欄為薪資）。
| 姓名 | 部門 | 金額 | 交易日期 | 薪資 |
|---|---|---|---|---|
| 張三 | 業務部 | 12,000 | 2024/01/05 | 52,000 |
| 李四 | 技術部 | 8,500 | 2024/01/12 | 48,000 |
| 王五 | 業務部 | 20,000 | 2024/02/01 | 61,000 |
| 陳六 | 人資部 | 5,000 | 2024/02/15 | 39,000 |
| 林七 | 技術部 | 15,000 | 2024/03/03 | 55,000 |
案例操作
操作 1：SortData
- 將游標停在 VBA 編輯器中 SortData 子程序內，按 F5。
- 跳出「排序方式」輸入框，輸入 1（升序）後按確定。
預期結果：工作表依第 3 欄「金額」由小到大排列：陳六 → 李四 → 張三 → 林七 → 王五，並跳出訊息「排序完成！依第 3 欄 升序 排列。」。再試一次輸入 2，會改為降序排列。
操作 2：SortMultiColumn
- 將游標停在 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
- 游標停在 FilterData 內，按 F5。
預期結果：工作表自動篩選出第 4 欄為「銷售部」的列：張三、王五、張三 共 3 列，表頭列出現下拉篩選箭頭，並跳出「已篩選出「銷售部」的資料。」。
操作 2：FilterAdvanced
- 先取消篩選（資料 → 篩選 → 清除），再按 F5 執行 FilterAdvanced。
預期結果：篩選出第 5 欄「薪資 > 50,000」的資料：張三、王五、張三、林七 共 4 筆，並跳出「篩選完成！薪資 > 50000 的資料共 4 筆。」。
操作 3：RemoveDuplicates
- 先清除篩選，再按 F5 執行 RemoveDuplicates。
預期結果：依「姓名 + 部門」組合移除重複列，張三 + 銷售部 兩列只剩一列，跳出「原始資料：6 筆 / 去重複後：5 筆」訊息。
操作 4：ExportFilteredData
- 按 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 SubRemoveDuplicates 會直接刪除原工作表的列，請先另存備份再執行。篩選條件與欄位編號（地區 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
- 游標停在 SummarizeByDepartment 內按 F5，不需輸入。
預期結果：自動刪除並重建「部門匯總」工作表：業務部（薪資總和 43,000、人數 3、平均 14,333）、技術部（23,500、2、11,750）、人資部（5,000、1、5,000），並跳出「部門匯總完成！共 3 個部門。」。
操作 2：MonthlySalesSummary
- 游標停在 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
- 游標停在 CountIfAnalysis 內按 F5。
- 在「請輸入要分析的部門名稱」輸入框輸入 業務部 後按確定。
預期結果：跳出「業務部 分析報告：人數 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
- 游標停在 HighlightTopPerformers 內按 F5，不需輸入。
預期結果：平均薪資約 51,667。張三、王五、張三、林七 這 4 列（薪資高於平均）整列標成淺綠色，資料表最下方新增一列「平均值」（橘色）。
操作 2：HighlightDuplicates
- 按 F5 執行 HighlightDuplicates。
預期結果：依「姓名 + 部門」組合比對，張三 + 業務部 出現的 2 列都被標成橘色，跳出「重複資料標記完成！共 1 筆重複。」。
操作 3：ColorScaleByValue
- 按 F5 執行 ColorScaleByValue。
預期結果：第 5 欄薪資依數值大小套用紅 → 綠漸層：最低 39,000 接近紅色、最高 61,000 接近綠色，中間依比例混合。
操作 4：MarkExpiredItems
- 按 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
自動分析整張資料表。
- 確認資料工作表為目前作用工作表，游標停在 GenerateReport 內按 F5。
預期結果：建立「統計報告」工作表，包含：一、基本資料概況（總資料筆數 4、欄位數量 4）；二、數值欄位統計（薪資：平均 50,000、總和 200,000、最大 61,000、最小 39,000、計數 4）；三、分類欄位統計（部門唯一值 3 個）；四、報告資訊（生成日期、資料來源、總筆數）。
操作 2：AutoCleanData
清除文字欄位的前後空白。
- 先故意在任一個姓名儲存格輸入「 張三 」（前後各一個空白）。
- 按 F5 執行 AutoCleanData。
預期結果：所有文字欄位的前後空白被移除，「 張三 」變回「張三」，並跳出「資料清理完成！處理了 N 個欄位的空白字元。」。
操作 3：MergeAndDedupe
把工作簿內所有工作表合併去重複。
- 新增兩張結構相同的工作表（例如「一月」「二月」），各放 3 筆資料，其中一筆完全相同（例如都是「E002 李四 技術部 48,000」）。
- 游標停在 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 SubGenerateReport 會自動判斷欄位是否為數值；文字欄位則統計唯一值數量。MergeAndDedupe 會把工作簿「所有」工作表都合併進來，請確認沒有不該合併的附表。
網路爬蟲
06 Yahoo Finance 股價爬蟲
單元目標：練習抓取即時股價、多股行情、下載歷史資料與布林通道分析。（需網路連線）
操作檔案：
06_YahooFinanceStockScraper.bas準備資料
本單元不需要準備資料表格。注意：即時報價功能在 06 模組內無法運作，必須改用 JsonParser.bas 內的巨集，下面步驟已標明「檔案」。
案例操作
操作 1：GetRealtimePriceFull（JsonParser.bas）
查單一股票即時報價。
- 確認已匯入 JsonParser.bas（需在 06 之前匯入也可以，兩者獨立）。
- 在 JsonParser 模組中，游標停在 GetRealtimePriceFull 內按 F5。
- 在輸入框輸入 2330.TW（台積電）後按確定，等待數秒。
預期結果：跳出完整的報價訊息框：股票名稱、交易所、貨幣、收盤價、前日收盤、開盤、最高、最低、成交量、漲跌、漲跌幅與查詢時間。輸入 AAPL、0700.HK 可查美股與港股。
操作 2：GetMultiplePricesFull（JsonParser.bas）
一次查詢多支股票並寫入工作表。
- 在 JsonParser 模組中按 F5 執行 GetMultiplePricesFull。
- 輸入 2330.TW,2454.TW,AAPL 後按確定。
預期結果：建立「Yahoo股價」工作表，每支股票一行（代號、名稱、目前價、前日收盤、開盤、最高、最低、成交量、漲跌、漲幅%、貨幣），上漲列為紅字、下跌列為綠字，並跳出「查詢完成！成功 3 / 3 支股票。」。
操作 3：DownloadHistoricalData（06 本檔）
下載歷史股價 CSV 到工作表。
- 在 06 模組中，游標停在 DownloadHistoricalData 內按 F5。
- 依序輸入股票代號 2330.TW、起始日期 2024-01-01、結束日期（預設為今天，直接按確定）。
預期結果：建立「2330.TW_歷史」工作表，欄位為 日期 / 開盤 / 最高 / 最低 / 收盤 / 成交量 / 調整後收盤，共約一年的日資料。此巨集不需解析 JSON，可正常運作。
操作 4：BollingerBandsAnalysis（06 本檔）
用一年歷史資料計算布林通道並出圖。
- 在 06 模組中按 F5 執行 BollingerBandsAnalysis。
- 輸入股票代號 2330.TW 後按確定（會自動下載近一年資料）。
預期結果：建立「2330.TW_布林通道」工作表：20 日均線、上軌（+2SD）、下軌（-2SD）、通道寬度、%B 與信號（突破上軌看跌 / 跌破下軌看涨 / 偏高 / 偏低 / 區間），並自動產生一張股價走勢折線圖。
操作 5：GetMarketIndices（06 本檔，會失敗）
抓取全球大盤指數。
- 在 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
建立固定選項的下拉選單。
- 游標停在 CreateDropdownList 內按 F5。
- 點選 C2 儲存格，右側會出現下拉箭頭，從中選擇縣市（台北、台中、台南、高雄、新北）。
- 在 C2 直接輸入不存在的值，例如「台南市」，按 Enter。
預期結果：下拉選單建立於 C2:C100。輸入非法縣市時會跳出「輸入錯誤」的錯誤訊息並阻止輸入；從下拉選擇則可正常輸入。
操作 2：CreateNumberValidation + CreateDecimalValidation + CreateDateValidation + CreateStringLengthValidation + CreateCustomValidation
依序建立數值 / 小數 / 日期 / 長度 / 自訂公式驗證並測試。
- 依序把游標停在每個巨集內按 F5（不用先手動輸入資料）。
- 測試 E 欄：輸入 150 會被擋（限 1~100 整數）；輸入 50 可通過。
- 測試 F 欄：輸入 1.5 會被擋（限 0~1 小數，顯示為百分比）。
- 測試 G 欄：輸入 2023/12/31 會被擋（限 2024/01/01 ~ 2025/12/31）。
- 測試 H 欄：輸入 12345 會被擋（限 8 個字元）。
- 測試 I 欄：輸入 3 會被擋（限偶數，自訂公式 ISEVEN）。
預期結果：每個欄位各自套用不同的驗證規則：E 整數範圍、F 小數百分比、G 日期範圍、H 字串長度、I 偶數限制。輸入不合規格一律跳出錯誤訊息。
操作 3：CreateUniqueValidation
防止同欄重複值。
- 按 F5 執行 CreateUniqueValidation。
- 在 J2 輸入 A001，再於 J3 輸入 A001。
預期結果：J2 正常輸入，J3 輸入相同值時跳出「重複值」錯誤，確保單號 / 身分證字號不重複。
操作 4：CreateFormWithValidation
建立完整的員工資料輸入表單。
- 按 F5 執行 CreateFormWithValidation（此巨集會清空 A1:F30，請在空白工作表執行）。
- 依序測試 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
動態下拉選單與驗證管理。
- 按 F5 執行 SetupDynamicDropdown。
- 切回工作表，在 Y 欄「部門」表格最下方新增一格輸入「法務部」。
- 點選 C2 儲存格，展開下拉選單確認「法務部」已自動出現。
- 按 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 FunctionCreateFormWithValidation 會覆蓋 A1:F30 的內容；CreateDropdownFromRange 與 SetupDynamicDropdown 會在 Z、Y 欄建立選項清單並隱藏該欄。
日誌
08 日誌系統
單元目標：練習把程式執行過程、股價、API 呼叫與工作表變更記錄下來，並自動清理舊日誌。
操作檔案：
08_LoggingSystem.bas準備資料
本單元不需準備資料表格。文字日誌檔會寫在工作簿「同一個資料夾」中，檔名為 log_日期.txt。
案例操作
操作 1：LogSystemInfo
把系統環境寫入日誌檔。
- 游標停在 LogSystemInfo 內按 F5。
預期結果：跳出訊息告知日誌路徑；在工作簿旁產生 log_日期.txt，內容包含 Excel 版本、作業系統、工作簿路徑、使用者、電腦名稱與執行時間，同時輸出到立即視窗（Ctrl+G 可查看）。
操作 2：LogStockPrice
把每日股價記錄到工作表與日誌檔。
- 按 F5 執行 LogStockPrice。
- 輸入股票代號 2330.TW 後按確定（需網路）。
預期結果：建立「股價日誌」工作表（若已存在則直接附加），新增一筆 時間 / 代號 / 名稱 / 收盤價 / 漲跌 / 漲幅% 紀錄並自動上色，同時寫入文字日誌檔，跳出「股價已記錄至「股價日誌」工作表。」。
操作 3：LogApiCall + ShowApiLogSummary
追蹤 API 呼叫品質。
- 按 F5 執行 LogApiCall，輸入股票代號 2330.TW，呼叫類型輸入「即時股價」。
- 再按 F5 執行 ShowApiLogSummary。
預期結果：「API 日誌」工作表新增一筆 成功 / 耗時(ms) 紀錄並寫入文字檔。ShowApiLogSummary 顯示統計：總呼叫次數、成功、失敗、平均耗時、總耗時。
操作 4：EnableChangeTracking
記錄工作表的變更。
- 按 F5 執行 EnableChangeTracking（會記錄目前整張工作表的初始狀態）。
- 切回工作表，隨意修改任一儲存格的內容。
- 再回到 VBA，按 F5 執行 ShowPriceLog 以外的檢視方式，直接點開「變更日誌」工作表查看。
預期結果：建立「變更日誌」工作表：先記錄每格初始值；修改儲存格後會在該工作表留下 變更時間 / 工作表 / 儲存格 / 舊值 / 新值 的紀錄。
操作 5：StockAnalysisWithLog
完整的「帶日誌股價分析」流程示範。
- 按 F5 執行 StockAnalysisWithLog（需網路，且需 32 位元 Office 才能解析 JSON）。
- 輸入股票代號 2330.TW 後按確定。
預期結果：逐步寫入 5 個階段日誌（取得報價 → 解析 JSON → 提取資料 → 寫入工作表 → 完成），建立「分析結果」工作表，最後跳出「股價分析完成！… 耗時 … 秒」並顯示日誌路徑。
操作 6：ClearOldLogs + ShowLogFiles
清理與檢視日誌。
- 按 F5 執行 ShowLogFiles 查看目前有哪些 log_*.txt。
- 按 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 解析（即時股價）。
- 在 JsonParser 模組中，游標停在 GetRealtimePriceFull 內按 F5。
- 輸入 2330.TW 後按確定（需網路）。
預期結果：跳出完整報價訊息框，代表整段 JSON 已成功解析並取出欄位值。這是本工具集唯一能正常查即時報價的現成巨集。
操作 2：GetMultiplePricesFull
多股行情寫入工作表。
- 按 F5 執行 GetMultiplePricesFull。
- 輸入 2330.TW,2454.TW,AAPL 後按確定。
預期結果：建立「Yahoo股價」工作表，多支股票的 11 個欄位（代號、名稱、價格、開高低、成交量、漲跌、漲幅、貨幣），漲紅跌綠，並顯示成功筆數。
操作 3：JsonToObject + JsonGet 立即視窗測試
在立即視窗手動驗證 JSON 函數。
- 按 Ctrl+G 打開立即視窗，貼上下列指令後按 Enter：
- Dim j As Object: Set j = JsonToObject("{\"name\":\"張三\",\"score\":95}")
- 再貼上 ? 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 SubJsonParser.bas 是 08 日誌系統的依賴（08 會呼叫 JsonToObject），請在 08 之前匯入。64 位元 Office 無法使用 ScriptControl，JSON 相關功能會直接報錯。
常見疑難排解
- 按 F5 沒反應：確認游標停在 Sub 名稱內（不是停在註解行），或先檢查是否有其他子程序選到。
- 巨集被封鎖：將工作簿所在資料夾加入信任位置，或開啟檔案時按「啟用內容」。
- 股價顯示「取得資料失敗」：確認有網路；即時報價請改用 JsonParser.bas 的 GetRealtimePriceFull。
- JSON 相關巨集報錯：MSScriptControl.ScriptControl 僅支援 32 位元 Office，請改用 32 位元版本。
- 工作表被刪掉：多數巨集會先刪除再重建同名工作表（統計報告、Yahoo股價、股價日誌…），操作前請先另存備份。
沒有留言:
張貼留言