EXCEL里添加实时金价并自动刷新的代码

实时金价监控工具是一个基于 Excel/WPS VBA 的数据采集小工具，主要用于通过API接口获取浙商银行积存金实时价格，并在工作表中自动刷新显示。

该功能适合用于黄金投资跟踪、价格监控表、财务分析模板、贵金属看板等工作簿。当用户需要实时关注金价变动时，只需点击按钮即可获取最新价格，并可开启自动刷新模式，无需手动反复查询。

本版本针对表单控件按钮进行了适配，同时也支持从宏列表或VBA编辑器中手动运行。代码中加入了JSON解析、HTTP请求、错误处理、自动刷新调度、状态栏提示等增强逻辑，适合在Excel与WPS表格中直接使用。

📌 核心功能一览

功能 说明
一键获取金价 点击按钮后从API获取最新积存金价格
自动显示时间戳 在价格旁自动记录获取时间
涨跌幅百分比显示 自动解析并显示涨跌幅，支持百分比格式
自动刷新模式 可设置间隔时间，定时自动更新金价
支持表单控件按钮 可通过工作表上的表单按钮触发
支持手动运行 即使不是按钮触发，也可手动执行
智能错误处理 HTTP错误、解析失败时给出友好提示
状态栏提示 获取过程中实时显示状态信息
颜色标识 成功/失败/涨跌均有不同颜色区分
Excel/WPS通用 适用于Microsoft Excel与WPS表格VBA环境
配置参数集中管理 所有可调参数集中在代码顶部，方便修改

⚙️ 项目结构说明

模块组成

模块 类型 作用
标准模块 标准模块 存放所有金价获取和刷新管理代码
工作表按钮 表单控件 点击后调用获取金价或启动自动刷新宏

推荐使用场景

场景 说明
黄金投资跟踪表 实时关注金价变动
贵金属报价看板 大屏展示金价信息
财务分析模板 引用实时金价进行测算
成本核算表 根据金价计算加工成本
价格监控系统 多产品价格监控
个人理财台账 记录黄金资产变动

🚀 使用方式

第一步：打开 VBA 编辑器

在 Excel 或 WPS 表格中按下：

Alt + F11

进入 VBA 编辑器。

第二步：插入标准模块

在 VBA 编辑器中依次点击：

插入 → 模块

新建一个标准模块，例如 Module1。

第三步：粘贴代码

将本文下方的完整 VBA 代码复制到标准模块中。

第四步：配置参数（可选）

在代码顶部的可配置参数区域，可以根据需要修改：

参数 说明 默认值
TARGET_CELL 金价显示位置 A4
TIME_COL_OFFSET 时间戳列偏移 1（B列）
RATE_COL_OFFSET 涨跌幅列偏移 2（C列）
DEFAULT_REFRESH_INTERVAL 默认刷新间隔（秒） 60
PRICE_FORMAT 价格显示格式 0.00
RATE_FORMAT 涨跌幅显示格式 0.00%
COLOR_SUCCESS 成功背景色 浅绿色
COLOR_ERROR 错误背景色 浅红色

第五步：插入表单按钮

返回工作表，依次点击：

开发工具 → 插入 → 表单控件 → 按钮

在工作表顶部或右侧放置一个按钮。

第六步：指定宏

给按钮指定宏，可选：

宏名称 功能
GetZSGoldPrice 手动获取一次金价
StartAutoRefresh 启动自动刷新
StopAutoRefresh 停止自动刷新

📋 完整代码

标准模块代码

Option Explicit

' ========================================
'  可配置参数区域 - 修改前请确认
' ========================================

' ----- 单元格位置配置 -----
Public Const TARGET_CELL As String = "A4"                ' 金价显示位置
Public Const TIME_COL_OFFSET As Integer = 1              ' 时间戳列偏移（0=同一列，1=B列）
Public Const RATE_COL_OFFSET As Integer = 2              ' 涨跌幅列偏移（0=同一列，2=C列）
Public Const TARGET_SHEET As String = ""                 ' 工作表名称（空字符串表示使用活动工作表）

' ----- API配置 -----
Public Const API_URL As String = "https://api.jdjygold.com/gw2/generic/jrm/h5/m/stdLatestPrice?productSku=1961543816"
Public Const PRODUCT_SKU As String = "1961543816"        ' 产品SKU编码
Public Const REQUEST_BODY_TEMPLATE As String = "{""reqData"": {""productSku"": ""{SKU}""}}"

' ----- HTTP请求头 -----
Public Const HEADER_CONTENT_TYPE As String = "application/json"
Public Const HEADER_ACCEPT As String = "application/json"
Public Const HEADER_ORIGIN As String = "https://www.jd.com"
Public Const HEADER_REFERER As String = "https://www.jd.com/"

' ----- 超时设置（毫秒） -----
Public Const TIMEOUT_RESOLVE As Long = 5000              ' DNS解析超时
Public Const TIMEOUT_CONNECT As Long = 5000              ' 连接超时
Public Const TIMEOUT_SEND As Long = 10000                ' 发送超时
Public Const TIMEOUT_RECEIVE As Long = 10000             ' 接收超时

' ----- 刷新时间配置（秒） -----
Public Const DEFAULT_REFRESH_INTERVAL As Double = 60     ' 默认刷新间隔
Public Const MIN_REFRESH_INTERVAL As Integer = 10        ' 最小刷新间隔
Public Const STATUS_CLEAR_DELAY As Long = 3              ' 状态栏清除延迟

' ----- 显示格式配置 -----
Public Const PRICE_FORMAT As String = "0.00"             ' 价格数字格式
Public Const TIME_FORMAT As String = "yyyy-mm-dd hh:mm:ss"  ' 时间戳格式
Public Const RATE_FORMAT As String = "0.00%"             ' 涨跌幅百分比格式
Public Const LOADING_TEXT As String = "加载中..."        ' 加载提示文字
Public Const ERROR_TEXT As String = "错误"               ' 错误提示文字
Public Const FAIL_TEXT As String = "获取失败"            ' 失败提示文字

' ----- 颜色配置（使用长整型数值，RGB(红,绿,蓝)转换公式：红 + 绿*256 + 蓝*65536） -----
Public Const COLOR_SUCCESS As Long = 14474460            ' RGB(220, 255, 220) 浅绿色
Public Const COLOR_ERROR As Long = 15132391              ' RGB(255, 230, 230) 浅红色
Public Const COLOR_NEUTRAL As Long = 16777215            ' RGB(255, 255, 255) 白色

' ========================================
'  全局变量（运行时修改）
' ========================================
Public RefreshEnabled As Boolean                         ' 刷新启用标志
Public RefreshInterval As Double                         ' 当前刷新间隔（秒）
Public NextRefreshTime As Date                           ' 下一次刷新时间
Public NextStatusClearTime As Date                       ' 下一次清除状态栏时间
Private RefreshInProgress As Boolean                     ' 防止重复进入刷新

' ========================================
'  核心功能函数
' ========================================

' 获取浙商银行积存金价格并显示在指定单元格
Sub GetZSGoldPrice(Optional ByVal ShowErrorMessage As Boolean = True)
    On Error GoTo ErrorHandler

    Dim http As Object
    Dim url As String
    Dim requestBody As String
    Dim response As String
    Dim priceValue As Double
    Dim targetCell As Range
    Dim rateValue As Double

    If RefreshInProgress Then Exit Sub
    RefreshInProgress = True

    ' 获取目标单元格
    Set targetCell = GetTargetCell()

    ' 构建请求
    url = API_URL
    requestBody = BuildRequestBody()

    ' 状态栏提示
    Application.StatusBar = "正在获取金价..."

    ' 在目标单元格显示加载提示
    targetCell.Value = LOADING_TEXT
    targetCell.NumberFormat = "@"
    targetCell.Interior.Color = COLOR_NEUTRAL

    ' 清空相邻单元格
    ClearAdjacentCells targetCell

    ' 创建HTTP请求
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")

    ' 发送POST请求
    With http
        .setTimeouts TIMEOUT_RESOLVE, TIMEOUT_CONNECT, TIMEOUT_SEND, TIMEOUT_RECEIVE
        .Open "POST", url, False
        .setRequestHeader "Content-Type", HEADER_CONTENT_TYPE
        .setRequestHeader "Accept", HEADER_ACCEPT
        .setRequestHeader "Origin", HEADER_ORIGIN
        .setRequestHeader "Referer", HEADER_REFERER
        .send requestBody

        ' 检查HTTP状态
        If .Status <> 200 Then
            targetCell.Value = "错误: HTTP " & .Status
            targetCell.Interior.Color = COLOR_ERROR
            Application.StatusBar = "金价获取失败：HTTP " & .Status

            If ShowErrorMessage Then
                MsgBox "HTTP错误：" & .Status & " - " & .statusText, vbExclamation, "获取金价失败"
            End If

            GoTo CleanUp
        End If

        response = .responseText
    End With

    ' 调试输出
    Debug.Print "原始响应: " & response

    ' 解析JSON提取价格
    priceValue = ParseGoldPrice(response)

    ' 检查是否成功获取价格
    If priceValue > 0 Then
        ' 输出到目标单元格
        targetCell.Value = priceValue
        targetCell.NumberFormat = PRICE_FORMAT
        targetCell.Interior.Color = COLOR_SUCCESS

        ' 添加时间戳
        targetCell.Offset(0, TIME_COL_OFFSET).Value = Now()
        targetCell.Offset(0, TIME_COL_OFFSET).NumberFormat = TIME_FORMAT

        ' 显示涨跌幅（百分比格式）
        rateValue = ParseRate(response)
        With targetCell.Offset(0, RATE_COL_OFFSET)
            .Value = rateValue
            .NumberFormat = RATE_FORMAT
            .Interior.Color = GetRateColor(rateValue)
        End With

        ' 状态栏提示成功
        Application.StatusBar = "金价获取成功：" & Format(priceValue, PRICE_FORMAT) & " 元/克"
        ScheduleClearStatusBar STATUS_CLEAR_DELAY
    Else
        targetCell.Value = FAIL_TEXT
        targetCell.Interior.Color = COLOR_ERROR
        Application.StatusBar = "金价解析失败"

        If ShowErrorMessage Then
            MsgBox "未能解析金价数据，请检查网络或API接口。" & vbCrLf & _
                   "原始响应：" & Left(response, 200), vbExclamation, "解析失败"
        End If
    End If

CleanUp:
    Set http = Nothing
    RefreshInProgress = False
    Exit Sub

ErrorHandler:
    If Not targetCell Is Nothing Then
        targetCell.Value = ERROR_TEXT
        targetCell.Interior.Color = COLOR_ERROR
    End If

    Application.StatusBar = "金价获取错误：" & Err.Description

    If ShowErrorMessage Then
        MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
               "发生在: GetZSGoldPrice", vbCritical, "运行时错误"
    End If

    Resume CleanUp
End Sub

' ========================================
'  辅助函数
' ========================================

' 获取目标单元格
Private Function GetTargetCell() As Range
    Dim ws As Worksheet
    
    If TARGET_SHEET <> "" Then
        Set ws = ThisWorkbook.Worksheets(TARGET_SHEET)
    Else
        Set ws = ThisWorkbook.ActiveSheet
    End If
    
    Set GetTargetCell = ws.Range(TARGET_CELL)
End Function

' 构建请求体
Private Function BuildRequestBody() As String
    BuildRequestBody = Replace(REQUEST_BODY_TEMPLATE, "{SKU}", PRODUCT_SKU)
End Function

' 清除相邻单元格内容
Private Sub ClearAdjacentCells(ByVal targetCell As Range)
    If TIME_COL_OFFSET > 0 Then
        targetCell.Offset(0, TIME_COL_OFFSET).ClearContents
        targetCell.Offset(0, TIME_COL_OFFSET).Interior.Color = COLOR_NEUTRAL
    End If
    
    If RATE_COL_OFFSET > 0 And RATE_COL_OFFSET <> TIME_COL_OFFSET Then
        targetCell.Offset(0, RATE_COL_OFFSET).ClearContents
        targetCell.Offset(0, RATE_COL_OFFSET).Interior.Color = COLOR_NEUTRAL
    End If
End Sub

' 根据涨跌幅返回颜色
Private Function GetRateColor(ByVal rateValue As Double) As Long
    If rateValue > 0 Then
        GetRateColor = RGB(255, 200, 200)  ' 浅红色 - 上涨
    ElseIf rateValue < 0 Then
        GetRateColor = RGB(200, 255, 200)  ' 浅绿色 - 下跌
    Else
        GetRateColor = COLOR_NEUTRAL        ' 白色 - 持平
    End If
End Function

' ========================================
'  JSON解析函数
' ========================================

' 解析JSON中的金价
Private Function ParseGoldPrice(ByVal jsonText As String) As Double
    Dim priceStr As String
    Dim startPos As Long, endPos As Long

    ' 方法1：精确查找 "price":" 后面的数字
    startPos = InStr(1, jsonText, """price"":""", vbTextCompare)
    If startPos > 0 Then
        startPos = startPos + 9
        endPos = InStr(startPos, jsonText, """")
        If endPos > startPos Then
            priceStr = Mid(jsonText, startPos, endPos - startPos)
            priceStr = Trim(priceStr)
            If IsNumeric(priceStr) Then
                ParseGoldPrice = CDbl(priceStr)
                Debug.Print "解析到金价: " & priceStr
                Exit Function
            End If
        End If
    End If

    ' 方法2：使用正则表达式
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")

    With regex
        .Global = False
        .IgnoreCase = True
        .Pattern = """price""\s*:\s*""([\d.]+)"""

        If .Test(jsonText) Then
            Dim matches As Object
            Set matches = .Execute(jsonText)
            If matches.Count > 0 Then
                priceStr = matches(0).SubMatches(0)
                If IsNumeric(priceStr) Then
                    ParseGoldPrice = CDbl(priceStr)
                    Debug.Print "正则解析到金价: " & priceStr
                    Set regex = Nothing
                    Exit Function
                End If
            End If
        End If
    End With

    Set regex = Nothing
    ParseGoldPrice = 0
End Function

' 解析涨跌幅（返回百分比数值）
Private Function ParseRate(ByVal jsonText As String) As Double
    Dim startPos As Long, endPos As Long
    Dim rateStr As String
    Dim rateValue As Double

    startPos = InStr(1, jsonText, """upAndDownRate"":""", vbTextCompare)
    If startPos > 0 Then
        startPos = startPos + 17
        endPos = InStr(startPos, jsonText, """")
        If endPos > startPos Then
            rateStr = Mid(jsonText, startPos, endPos - startPos)
            rateStr = Trim(rateStr)
            
            If Right(rateStr, 1) = "%" Then
                rateStr = Left(rateStr, Len(rateStr) - 1)
            End If
            
            If IsNumeric(rateStr) Then
                rateValue = CDbl(rateStr) / 100
                ParseRate = rateValue
                Debug.Print "解析到涨跌幅: " & Format(rateValue, RATE_FORMAT)
                Exit Function
            End If
        End If
    End If

    ParseRate = 0
End Function

' ========================================
'  状态栏管理
' ========================================

Sub ClearStatusBar()
    Application.StatusBar = False
End Sub

Private Sub ScheduleClearStatusBar(ByVal seconds As Long)
    On Error Resume Next

    If NextStatusClearTime <> 0 Then
        Application.OnTime EarliestTime:=NextStatusClearTime, _
                           Procedure:="ClearStatusBar", _
                           Schedule:=False
    End If

    On Error GoTo 0

    NextStatusClearTime = DateAdd("s", seconds, Now)
    Application.OnTime EarliestTime:=NextStatusClearTime, _
                       Procedure:="ClearStatusBar", _
                       Schedule:=True
End Sub

' ========================================
'  自动刷新管理
' ========================================

Sub StartAutoRefresh()
    RefreshEnabled = True

    If RefreshInterval < MIN_REFRESH_INTERVAL Then
        RefreshInterval = DEFAULT_REFRESH_INTERVAL
    End If

    CancelNextRefresh
    Call GetZSGoldPrice(True)
    Call ScheduleNextRefresh

    MsgBox "自动刷新已启动，每 " & RefreshInterval & " 秒刷新一次", vbInformation, "金价监控"
End Sub

Sub StopAutoRefresh(Optional ByVal ShowMessage As Boolean = True)
    RefreshEnabled = False
    CancelNextRefresh

    If ShowMessage Then
        MsgBox "自动刷新已停止", vbInformation, "金价监控"
    End If
End Sub

Sub ScheduleNextRefresh()
    If RefreshEnabled Then
        CancelNextRefresh
        NextRefreshTime = DateAdd("s", CLng(RefreshInterval), Now)
        Application.OnTime EarliestTime:=NextRefreshTime, _
                           Procedure:="TimedRefresh", _
                           Schedule:=True
    End If
End Sub

Private Sub CancelNextRefresh()
    On Error Resume Next

    If NextRefreshTime <> 0 Then
        Application.OnTime EarliestTime:=NextRefreshTime, _
                           Procedure:="TimedRefresh", _
                           Schedule:=False
        NextRefreshTime = 0
    End If

    On Error GoTo 0
End Sub

Sub TimedRefresh()
    If RefreshEnabled Then
        Call GetZSGoldPrice(False)
        Call ScheduleNextRefresh
    End If
End Sub

' ========================================
'  配置管理函数
' ========================================

Sub SetRefreshInterval(seconds As Integer)
    If seconds >= MIN_REFRESH_INTERVAL Then
        RefreshInterval = seconds

        If RefreshEnabled Then
            Call ScheduleNextRefresh
        End If

        MsgBox "刷新间隔已设置为 " & seconds & " 秒", vbInformation, "设置成功"
    Else
        MsgBox "刷新间隔不能小于 " & MIN_REFRESH_INTERVAL & " 秒，避免被API限制", vbExclamation, "设置无效"
    End If
End Sub

Function GetCurrentInterval() As Double
    GetCurrentInterval = RefreshInterval
End Function

Function IsAutoRefreshEnabled() As Boolean
    IsAutoRefreshEnabled = RefreshEnabled
End Function

' ========================================
'  测试函数
' ========================================

Function TestGoldPrice() As Double
    Call GetZSGoldPrice(True)

    Dim cell As Range
    Set cell = GetTargetCell()
    
    If IsNumeric(cell.Value) Then
        TestGoldPrice = CDbl(cell.Value)
    Else
        TestGoldPrice = 0
    End If
End Function

Sub TestAPIConnection()
    Dim startTime As Double
    startTime = Timer
    
    Call GetZSGoldPrice(True)
    
    MsgBox "API测试完成，耗时: " & Format(Timer - startTime, "0.00") & " 秒", vbInformation, "测试完成"
End Sub

' ========================================
'  重置所有设置
' ========================================

Sub ResetToDefaults()
    If RefreshEnabled Then
        Call StopAutoRefresh(False)
    End If
    
    RefreshInterval = DEFAULT_REFRESH_INTERVAL
    RefreshEnabled = False
    NextRefreshTime = 0
    NextStatusClearTime = 0
    RefreshInProgress = False
    
    Call ClearStatusBar
    
    Dim cell As Range
    Set cell = GetTargetCell()
    cell.ClearContents
    cell.Interior.Color = COLOR_NEUTRAL
    ClearAdjacentCells cell
    
    MsgBox "已重置为默认配置", vbInformation, "重置完成"
End Sub

🔍 技术要点详解

1. API 数据获取

代码使用 MSXML2.ServerXMLHTTP.6.0 对象发送 POST 请求：

Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")

该对象支持设置超时时间，避免长时间等待：

.setTimeouts TIMEOUT_RESOLVE, TIMEOUT_CONNECT, TIMEOUT_SEND, TIMEOUT_RECEIVE

API 地址和请求体均可通过顶部常量配置，方便切换不同产品。

2. JSON 数据解析

代码提供了两种 JSON 解析方式：

方式一：字符串查找

startPos = InStr(1, jsonText, """price"":""", vbTextCompare)

方式二：正则表达式（备用）

.Pattern = """price""\s*:\s*""([\d.]+)"""

双重解析机制提高了数据提取的可靠性。

3. 涨跌幅百分比处理

API 返回的涨跌幅为百分比字符串（如 “15%”），代码将其转换为数值类型：

If Right(rateStr, 1) = "%" Then
    rateStr = Left(rateStr, Len(rateStr) - 1)
End If
rateValue = CDbl(rateStr) / 100

再通过单元格格式 RATE_FORMAT 显示为 “15.00%”。

4. 自动刷新调度

使用 Application.OnTime 实现定时刷新：

Application.OnTime EarliestTime:=NextRefreshTime, _
                   Procedure:="TimedRefresh", _
                   Schedule:=True

调度管理包含：

  • 取消旧任务避免重复
  • 间隔时间可动态调整
  • 最小间隔限制避免 API 限制

5. 状态栏反馈

整个获取过程通过状态栏向用户反馈进度：

Application.StatusBar = "正在获取金价..."
Application.StatusBar = "金价获取成功：" & Format(priceValue, PRICE_FORMAT) & " 元/克"

获取完成后自动清除状态栏：

ScheduleClearStatusBar STATUS_CLEAR_DELAY

6. 错误处理机制

代码包含多层错误处理：

  • HTTP 状态检查：If .Status <> 200 Then
  • 数据解析失败：If priceValue > 0 Then
  • 运行时错误：On Error GoTo ErrorHandler

错误信息通过状态栏和消息框双重提示。

7. 配置参数集中管理

所有可调整参数集中在代码顶部：

' ----- 单元格位置配置 -----
Public Const TARGET_CELL As String = "A4"
Public Const TIME_COL_OFFSET As Integer = 1
Public Const RATE_COL_OFFSET As Integer = 2

' ----- 刷新时间配置 -----
Public Const DEFAULT_REFRESH_INTERVAL As Double = 60
Public Const MIN_REFRESH_INTERVAL As Integer = 10

用户无需深入代码逻辑即可调整关键参数。

8. 颜色标识系统

不同状态使用不同颜色区分：

状态 颜色 说明
成功获取 浅绿色 数据正常
获取失败 浅红色 请求或解析错误
价格上涨 浅红色 涨跌幅 > 0
价格下跌 浅绿色 涨跌幅 < 0
价格持平 白色 涨跌幅 = 0

📊 相比普通金价获取代码的优化改进

优化项 普通代码 本增强版
数据获取 固定单元格 可通过配置修改目标位置
自动刷新 通常无 支持定时自动刷新
错误处理 简单或无 完善的错误处理机制
状态反馈 无 状态栏全程反馈
涨跌幅显示 文本显示 百分比格式化显示
颜色标识 无 成功/失败/涨跌颜色区分
JSON解析 单一方法 双重解析机制
超时控制 无 可配置超时时间
配置管理 硬编码 集中参数配置
工作表支持 仅活动表 支持指定工作表
测试功能 无 内置测试函数

💡 可自定义参数

修改显示位置

默认金价显示在 A4 单元格：

Public Const TARGET_CELL As String = "A4"

可修改为任意单元格，例如：

Public Const TARGET_CELL As String = "B2"   ' 显示在 B2
Public Const TARGET_CELL As String = "F10"  ' 显示在 F10

修改刷新间隔

默认每 60 秒刷新一次：

Public Const DEFAULT_REFRESH_INTERVAL As Double = 60

可修改为更短或更长的间隔：

Public Const DEFAULT_REFRESH_INTERVAL As Double = 30   ' 30 秒
Public Const DEFAULT_REFRESH_INTERVAL As Double = 120  ' 2 分钟

修改显示格式

价格格式：

Public Const PRICE_FORMAT As String = "0.00"

时间格式：

Public Const TIME_FORMAT As String = "yyyy-mm-dd hh:mm:ss"

涨跌幅格式：

Public Const RATE_FORMAT As String = "0.00%"

修改颜色值

使用 RGB 数值公式：红 + 绿*256 + 蓝*65536

' 示例：修改成功颜色为蓝色
Public Const COLOR_SUCCESS As Long = 16711680   ' RGB(0, 0, 255)

更换API产品

Public Const PRODUCT_SKU As String = "1961543816"        ' 产品SKU
Public Const REQUEST_BODY_TEMPLATE As String = "{""reqData"": {""productSku"": ""{SKU}""}}"

如需查询其他产品，只需修改 PRODUCT_SKU 即可。

🧩 扩展功能建议

多产品监控

可以在不同单元格监控不同产品：

Sub GetMultipleGoldPrices()
    ' 产品1
    PRODUCT_SKU = "1961543816"
    TARGET_CELL = "A4"
    Call GetZSGoldPrice(False)
    
    ' 产品2
    PRODUCT_SKU = "1961543817"
    TARGET_CELL = "A10"
    Call GetZSGoldPrice(False)
End Sub

数据记录

添加历史记录功能：

Sub RecordGoldPrice()
    Dim lastRow As Long
    lastRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row + 1
    
    ThisWorkbook.ActiveSheet.Range("E" & lastRow).Value = Now()
    ThisWorkbook.ActiveSheet.Range("F" & lastRow).Value = ThisWorkbook.ActiveSheet.Range("A4").Value
    ThisWorkbook.ActiveSheet.Range("G" & lastRow).Value = ThisWorkbook.ActiveSheet.Range("C4").Value
End Sub

价格预警

设置价格上下限提醒：

Sub CheckPriceAlert()
    Dim currentPrice As Double
    currentPrice = ThisWorkbook.ActiveSheet.Range("A4").Value
    
    If currentPrice > 500 Then
        MsgBox "金价已超过500元/克！", vbInformation, "价格预警"
    ElseIf currentPrice < 400 Then
        MsgBox "金价已低于400元/克！", vbInformation, "价格预警"
    End If
End Sub

🛠️ 按钮设置建议

推荐按钮组合

按钮名称 宏 用途
获取金价 GetZSGoldPrice 手动获取一次
启动刷新 StartAutoRefresh 开启自动刷新
停止刷新 StopAutoRefresh 关闭自动刷新
设置间隔 SetRefreshInterval 修改刷新间隔
测试连接 TestAPIConnection 测试API可用性

按钮文字建议

获取金价

或：

💰 获取实时金价

自动刷新按钮：

▶ 启动自动刷新

📐 推荐布局方式

位置 说明
冻结窗格右上方 按钮始终可见
价格显示区域旁 操作直观
独立控制面板 集中管理所有控制按钮

⚠️ 注意事项

  1. 本代码需要 联网 才能获取金价数据。
  2. API 接口可能有访问频率限制，不建议设置过短的刷新间隔。
  3. 默认最小刷新间隔为 10 秒，避免被 API 限制。
  4. 如果返回 “获取失败”，请检查网络连接或 API 是否可用。
  5. 部分网络环境可能需要配置代理或防火墙例外。
  6. WPS 表格对 VBA 的支持与 Excel 基本一致，但不同版本表现可能略有差异。
  7. 若宏安全级别较高，需要启用宏后才能使用。
  8. API 响应结构变化时，可能需要调整 JSON 解析逻辑。
  9. 长时间运行自动刷新可能会消耗较多系统资源。
  10. 建议在非工作时间进行大规模测试。

📦 常见问题

Q1：为什么获取不到金价？

可能原因：

  • 网络连接异常
  • API 接口暂时不可用
  • 产品 SKU 不正确
  • 防火墙阻止了请求
  • API 响应结构发生变化

建议运行 TestAPIConnection 测试连接。

Q2：刷新间隔可以设置多短？

最小间隔为 10 秒，这是为了避免被 API 限制。如需更短间隔，可以修改：

Public Const MIN_REFRESH_INTERVAL As Integer = 5   ' 改为5秒

但请注意 API 的使用限制。

Q3：可以同时监控多个产品吗？

可以。可以复制代码并为不同产品创建不同的配置。

Q4：数据会保存吗？

当前版本只显示最新数据，不保存历史记录。如需记录，可以参考扩展功能中的历史记录代码。

Q5：WPS 表格可以用吗？

通常可以使用。但需要确保 WPS 已安装 VBA 支持组件。

Q6：如何修改价格显示的颜色？

修改顶部配置中的颜色常量：

Public Const COLOR_SUCCESS As Long = 14474460   ' 成功颜色
Public Const COLOR_ERROR As Long = 15132391     ' 错误颜色

颜色值计算公式：红 + 绿*256 + 蓝*65536

💡 扩展方向

方向 说明
多产品监控 同时监控多个黄金产品
历史记录 自动记录价格变动历史
价格预警 价格超过阈值时提醒
图表展示 自动生成价格走势图
数据导出 导出历史数据到 CSV
邮件通知 价格变动时发送邮件
微信推送 通过 API 推送价格变动
多数据源 同时从多个 API 获取数据
汇率转换 自动转换不同货币计价
成本计算 根据金价自动计算加工成本

📞 技术支持

官网：

求助建议： http://xlcs.de/

邮件联系： admin@fdc.sd

📷 效果展示

实时金价监控效果

金价自动获取并显示在A4单元格，B列为时间戳，C列为涨跌幅

💎 浙商银行积存金
--.--
元/克
涨跌幅
--.--%
更新时间
--:--:--
点击刷新获取最新金价

XLCS — 让全成本测算更智能