Sub AutoUpdateStockData()
On Error GoTo ErrorHandler
' 记录开始时间
Dim startTime As Double
startTime = Timer
' 检查网络连接
If Not CheckInternetConnection() Then
MsgBox "网络连接不可用，请检查网络设置！", vbExclamation
Exit Sub
End If
' 获取自选股票列表
Dim stockList As Collection
Set stockList = GetMyStockList()
If stockList.Count = 0 Then
MsgBox "自选股票列表为空，请先添加自选股票！", vbInformation
Exit Sub
End If
' 更新状态
UpdateSystemStatus "数据更新中...", "正在获取股票数据"
' 获取行情数据
UpdateQuoteDataFromWeb stockList
' 获取财务数据
UpdateFinancialDataFromWeb stockList
' 获取公告数据
UpdateAnnouncementDataFromWeb stockList
' 更新系统状态
UpdateSystemStatus "数据更新完成", "最后更新时间: " & Now()
' 记录更新日志
LogUpdate "成功更新 " & stockList.Count & " 只股票的数据，耗时 " & Format(Timer - startTime, "0.00") & " 秒"
Exit Sub
ErrorHandler:
UpdateSystemStatus "更新失败", "错误: " & Err.Description
LogUpdate "更新失败: " & Err.Description, True
End Sub
Function CheckInternetConnection() As Boolean
On Error Resume Next
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "GET", "http://www.baidu.com", False
objHTTP.Send
CheckInternetConnection = (objHTTP.status = 200)
Set objHTTP = Nothing
On Error GoTo 0
End Function
Function GetMyStockList() As Collection
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("自选股票清单")
Dim stockList As New Collection
Dim lastRow As Long
lastRow = ws.cells(ws.rows.Count, "B").End(xlUp).row
Dim i As Long
For i = 2 To lastRow ' 假设第1行为表头
If ws.cells(i, "H").Value = "启用" Then ' 状态为启用的股票才进行更新
stockList.Add Array(ws.cells(i, "B").Value, ws.cells(i, "C").Value) ' 股票代码和名称
End If
Next i
Set GetMyStockList = stockList
End Function
Sub UpdateSystemStatus(status As String, detail As String)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("目录")
ws.Range("C2").Value = status ' 系统状态单元格
ws.Range("C3").Value = detail ' 详细信息单元格
DoEvents ' 刷新屏幕显示
End Sub
Sub LogUpdate(message As String, Optional isError As Boolean = False)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("系统设置")
Dim logRow As Long
logRow = ws.cells(ws.rows.Count, "A").End(xlUp).row + 1
ws.cells(logRow, "A").Value = Now() ' 时间戳
ws.cells(logRow, "B").Value = message ' 日志内容
If isError Then
ws.cells(logRow, "C").Value = "错误" ' 日志类型
ws.cells(logRow, "C").Interior.Color = RGB(255, 199, 206) ' 错误行标红
Else
ws.cells(logRow, "C").Value = "信息" ' 日志类型
End If
End Sub
Sub UpdateQuoteDataFromWeb(stockList As Collection)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("自选股票行情数据")
' 获取当前日期
Dim currentDate As String
currentDate = Format(Date, "yyyy-mm-dd")
' 获取系统设置的请求间隔
Dim minDelay As Integer, maxDelay As Integer
minDelay = ThisWorkbook.Worksheets("系统设置").Range("B5").Value ' 假设B5是最小延迟
maxDelay = ThisWorkbook.Worksheets("系统设置").Range("B6").Value ' 假设B6是最大延迟
' 创建IE对象
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False ' 设置为True可调试
' User-Agent列表
Dim userAgents As Variant
userAgents = Array( _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/91.0.4472.124 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Edge/91.0.864.59 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:89.0) Gecko/20100101 Firefox/89.0" _
)
Dim stock As Variant
For Each stock In stockList
' 检查是否已存在该日期和股票的数据，避免重复
Dim lastRow As Long
lastRow = ws.cells(ws.rows.Count, 1).End(xlUp).row
Dim isDuplicate As Boolean
isDuplicate = False
Dim i As Long
For i = 2 To lastRow
If ws.cells(i, 1).Value = currentDate And ws.cells(i, 2).Value = stock(0) Then
isDuplicate = True
Exit For
End If
Next i
If isDuplicate Then
UpdateSystemStatus "数据更新中...", "已存在 " & stock(1) & " 的今日数据，跳过更新"
GoTo NextStock
End If
' 构建行情页面URL
Dim url As String
url = "http://quote.eastmoney.com/" & GetMarketPrefix(CStr(stock(0))) & stock(0) & ".html"
' 随机选择User-Agent - 修复索引越界问题
Dim randomUA As String
randomUA = userAgents(Int(Rnd() * (UBound(userAgents) + 1)))
' 导航到页面
ie.Navigate url, Null, Null, "User-Agent: " & randomUA
' 等待页面加载完成
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
' 获取页面文档
Dim doc As Object
Set doc = ie.document
' 提取行情数据 - 显式转换参数类型
Dim quoteData As Collection
Set quoteData = ExtractQuoteData(doc, CStr(stock(0)), CStr(stock(1)))
' 写入数据
If Not quoteData Is Nothing Then
Dim nextRow As Long
nextRow = ws.cells(ws.rows.Count, 1).End(xlUp).row + 1
ws.cells(nextRow, 1).Value = currentDate ' 日期
ws.cells(nextRow, 2).Value = stock(0) ' 股票代码
ws.cells(nextRow, 3).Value = stock(1) ' 股票名称
' 填充其他字段
Dim j As Integer
For j = 1 To quoteData.Count
ws.cells(nextRow, 3 + j).Value = quoteData(j)
Next j
End If
' 更新进度
UpdateSystemStatus "数据更新中...", "正在更新行情数据: " & stock(1)
' 添加随机延迟，避免被封
Dim delaySeconds As Integer
delaySeconds = Int((maxDelay - minDelay + 1) * Rnd() + minDelay)
Application.Wait Now + TimeValue("0:00:" & delaySeconds)
NextStock:
Next stock
' 关闭IE
ie.Quit
Set ie = Nothing
End Sub
' 修复：参数声明为ByVal，允许值传递
Function ExtractQuoteData(doc As Object, ByVal stockCode As String, ByVal stockName As String) As Collection
Dim result As New Collection
Dim elements As Object
Dim element As Object
On Error Resume Next ' 忽略提取失败的字段
' 昨收盘
Set elements = doc.getElementsByClassName("price-td s2")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 开盘价
Set elements = doc.getElementsByClassName("price-td s3")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 收盘价
Set elements = doc.getElementsByClassName("price-td s1")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 开盘涨跌
Set elements = doc.getElementsByClassName("price-td s4")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 开盘涨跌%
Set elements = doc.getElementsByClassName("price-td s5")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 最高价
Set elements = doc.getElementsByClassName("price-td s6")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 最低价
Set elements = doc.getElementsByClassName("price-td s7")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 波幅
Set elements = doc.getElementsByClassName("price-td s8")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 波幅%
Set elements = doc.getElementsByClassName("price-td s9")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 成交量(万股)
Set elements = doc.getElementsByClassName("price-td s10")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 成交额(亿元)
Set elements = doc.getElementsByClassName("price-td s11")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 普通股数(万股)
Set elements = doc.getElementsByClassName("price-td s12")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 每股红利
Set elements = doc.getElementsByClassName("price-td s13")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 换手率(%)
Set elements = doc.getElementsByClassName("price-td s14")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' 换手率变动%
Set elements = doc.getElementsByClassName("price-td s15")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' H股价(HK$)
Set elements = doc.getElementsByClassName("price-td s16")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
' H/A股折溢价
Set elements = doc.getElementsByClassName("price-td s17")
If elements.Length > 0 Then result.Add Replace(elements(0).innerText, ",", "") Else result.Add ""
On Error GoTo 0 ' 恢复错误处理
Set ExtractQuoteData = result
End Function
' 修复：参数声明为ByVal
Function GetMarketPrefix(ByVal stockCode As String) As String
' 根据股票代码返回市场前缀
Select Case Left(stockCode, 1)
Case "6" ' 上海A股
GetMarketPrefix = "sh"
Case "0", "3" ' 深圳A股、创业板
GetMarketPrefix = "sz"
Case "4", "8" ' 北交所A股
GetMarketPrefix = "bj"
Case Else
GetMarketPrefix = "sh" ' 默认上海
End Select
End Function
Sub UpdateFinancialDataFromWeb(stockList As Collection)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("自选股票财务指标")
' 获取系统设置的请求间隔
Dim minDelay As Integer, maxDelay As Integer
minDelay = ThisWorkbook.Worksheets("系统设置").Range("B5").Value
maxDelay = ThisWorkbook.Worksheets("系统设置").Range("B6").Value
' 创建IE对象
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
' User-Agent列表
Dim userAgents As Variant
userAgents = Array( _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/91.0.4472.124 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Edge/91.0.864.59 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:89.0) Gecko/20100101 Firefox/89.0" _
)
Dim stock As Variant
For Each stock In stockList
' 构建财务数据页面URL (获取最新季度报告)
Dim url As String
url = "http://data.eastmoney.com/bbsj/" & Format(Date, "yyyymm") & "/yjbb/" & stock(0) & ".html"
' 随机选择User-Agent - 修复索引越界问题
Dim randomUA As String
randomUA = userAgents(Int(Rnd() * (UBound(userAgents) + 1)))
' 导航到页面
ie.Navigate url, Null, Null, "User-Agent: " & randomUA
' 等待页面加载完成
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
' 获取页面文档
Dim doc As Object
Set doc = ie.document
' 提取财务数据 - 显式转换参数类型
Dim financialData As Collection
Set financialData = ExtractFinancialData(doc, CStr(stock(0)), CStr(stock(1)))
' 写入数据（仅添加新数据，避免重复）
If Not financialData Is Nothing Then
Dim lastRow As Long
lastRow = ws.cells(ws.rows.Count, 1).End(xlUp).row
Dim isDuplicate As Boolean
isDuplicate = False
Dim i As Long
For i = 2 To lastRow
If ws.cells(i, 1).Value = stock(0) And ws.cells(i, 3).Value = financialData(1) Then ' 股票代码和报告期均相同
isDuplicate = True
Exit For
End If
Next i
If Not isDuplicate Then
Dim nextRow As Long
nextRow = ws.cells(ws.rows.Count, 1).End(xlUp).row + 1
ws.cells(nextRow, 1).Value = stock(0) ' 股票代码
ws.cells(nextRow, 2).Value = stock(1) ' 股票名称
' 填充其他字段
Dim j As Integer
For j = 1 To financialData.Count
ws.cells(nextRow, 2 + j).Value = financialData(j)
Next j
End If
End If
' 更新进度
UpdateSystemStatus "数据更新中...", "正在更新财务数据: " & stock(1)
' 添加随机延迟
Dim delaySeconds As Integer
delaySeconds = Int((maxDelay - minDelay + 1) * Rnd() + minDelay)
Application.Wait Now + TimeValue("0:00:" & delaySeconds)
Next stock
' 关闭IE
ie.Quit
Set ie = Nothing
End Sub
' 修复：参数声明为ByVal
Function ExtractFinancialData(doc As Object, ByVal stockCode As String, ByVal stockName As String) As Collection
Dim result As New Collection
Dim tables As Object, table As Object
Dim rows As Object, row As Object
Dim cells As Object, cell As Object
On Error Resume Next
' 查找财务数据表格（最新季度报告）
Set tables = doc.getElementsByTagName("table")
For Each table In tables
If InStr(LCase(table.className), "dataview") > 0 Or InStr(LCase(table.ID), "mainTable") > 0 Then
Set rows = table.getElementsByTagName("tr")
If rows.Length > 1 Then
' 假设第一行为表头，第二行为最新数据
Set row = rows(1)
Set cells = row.getElementsByTagName("td")
If cells.Length >= 15 Then ' 确保有足够的单元格
result.Add cells(0).innerText ' 报告期
result.Add Replace(cells(1).innerText, ",", "") ' 营业收入(亿元)
result.Add Replace(cells(2).innerText, ",", "") ' 净利润(亿元)
result.Add Replace(cells(3).innerText, ",", "") ' 净利润增长率(%)
result.Add Replace(cells(4).innerText, ",", "") ' 每股收益(元)
result.Add Replace(cells(5).innerText, ",", "") ' 每股净资产(元)
result.Add Replace(cells(6).innerText, ",", "") ' 净资产收益率(%)
result.Add Replace(cells(7).innerText, ",", "") ' 资产负债率(%)
result.Add Replace(cells(8).innerText, ",", "") ' 毛利率(%)
result.Add Replace(cells(9).innerText, ",", "") ' 净利率(%)
result.Add Replace(cells(10).innerText, ",", "") ' 流动比率
result.Add Replace(cells(11).innerText, ",", "") ' 速动比率
result.Add Replace(cells(12).innerText, ",", "") ' 存货周转率
result.Add Replace(cells(13).innerText, ",", "") ' 应收账款周转率
result.Add Replace(cells(14).innerText, ",", "") ' 经营活动现金流(亿元)
End If
Exit For
End If
End If
Next table
On Error GoTo 0
Set ExtractFinancialData = result
End Function
Sub UpdateAnnouncementDataFromWeb(stockList As Collection)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("自选股票公告链接清单")
' 获取系统设置的请求间隔
Dim minDelay As Integer, maxDelay As Integer
minDelay = ThisWorkbook.Worksheets("系统设置").Range("B5").Value
maxDelay = ThisWorkbook.Worksheets("系统设置").Range("B6").Value
' 创建IE对象
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
' User-Agent列表
Dim userAgents As Variant
userAgents = Array( _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/91.0.4472.124 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Edge/91.0.864.59 Safari/537.36", _
"Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:89.0) Gecko/20100101 Firefox/89.0" _
)
Dim stock As Variant
For Each stock In stockList
' 构建公告页面URL
Dim url As String
url = "http://data.eastmoney.com/notices/stock/" & stock(0) & ".html"
' 随机选择User-Agent - 修复索引越界问题
Dim randomUA As String
randomUA = userAgents(Int(Rnd() * (UBound(userAgents) + 1)))
' 导航到页面
ie.Navigate url, Null, Null, "User-Agent: " & randomUA
' 等待页面加载完成
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
' 获取页面文档
Dim doc As Object
Set doc = ie.document
' 提取公告数据（最近10条）- 显式转换参数类型
Dim announcementData As Collection
Set announcementData = ExtractAnnouncementData(doc, CStr(stock(0)), CStr(stock(1)))
' 写入数据（仅添加新公告）
If Not announcementData Is Nothing Then
Dim announcement As Variant
For Each announcement In announcementData
Dim lastRow As Long
lastRow = ws.cells(ws.rows.Count, 1).End(xlUp).row
Dim isDuplicate As Boolean
isDuplicate = False
Dim i As Long
For i = 2 To lastRow
If ws.cells(i, 1).Value = stock(0) And ws.cells(i, 4).Value = announcement(1) Then ' 股票代码和公告标题相同
isDuplicate = True
Exit For
End If
Next i
If Not isDuplicate Then
Dim nextRow As Long
nextRow = ws.cells(ws.rows.Count, 1).End(xlUp).row + 1
ws.cells(nextRow, 1).Value = stock(0) ' 股票代码
ws.cells(nextRow, 2).Value = stock(1) ' 股票名称
ws.cells(nextRow, 3).Value = announcement(0) ' 公告日期
ws.cells(nextRow, 4).Value = announcement(1) ' 公告标题
ws.cells(nextRow, 5).Value = announcement(2) ' 公告类型
ws.cells(nextRow, 6).Value = announcement(3) ' 公告链接
ws.Hyperlinks.Add Anchor:=ws.cells(nextRow, 6), Address:=announcement(3), TextToDisplay:=announcement(3)
ws.cells(nextRow, 7).Value = "未读" ' 阅读状态
ws.cells(nextRow, 8).Value = "中" ' 默认重要程度
End If
Next announcement
End If
' 更新进度
UpdateSystemStatus "数据更新中...", "正在更新公告数据: " & stock(1)
' 添加随机延迟
Dim delaySeconds As Integer
delaySeconds = Int((maxDelay - minDelay + 1) * Rnd() + minDelay)
Application.Wait Now + TimeValue("0:00:" & delaySeconds)
Next stock
' 关闭IE
ie.Quit
Set ie = Nothing
End Sub
' 修复：参数声明为ByVal
Function ExtractAnnouncementData(doc As Object, ByVal stockCode As String, ByVal stockName As String) As Collection
Dim result As New Collection
Dim tables As Object, table As Object
Dim rows As Object, row As Object
Dim cells As Object, cell As Object
Dim links As Object, link As Object
On Error Resume Next
' 查找公告数据表格
Set tables = doc.getElementsByTagName("table")
For Each table In tables
If InStr(LCase(table.className), "noticelist") > 0 Or InStr(LCase(table.ID), "notice") > 0 Then
Set rows = table.getElementsByTagName("tr")
Dim i As Integer
For i = 1 To 10 ' 获取最近10条公告
If i >= rows.Length Then Exit For
Set row = rows(i)
Set cells = row.getElementsByTagName("td")
If cells.Length >= 4 Then
Dim announcementItem(3) As String ' 日期、标题、类型、链接
' 公告日期
announcementItem(0) = cells(0).innerText
' 公告标题和链接
Set links = cells(1).getElementsByTagName("a")
If links.Length > 0 Then
announcementItem(1) = links(0).innerText
announcementItem(3) = links(0).href
Else
announcementItem(1) = cells(1).innerText
announcementItem(3) = ""
End If
' 公告类型
announcementItem(2) = cells(2).innerText
result.Add announcementItem
End If
Next i
Exit For
End If
Next table
On Error GoTo 0
Set ExtractAnnouncementData = result
End Function
以上代码请逐行检查一下，有问题告诉我一下
最新发布
本文介绍了解决IE浏览器关闭时出现的内存读取错误的方法。通过禁用潜在问题的加载项，成功解决了“0x025185b2”指令引用的内存不能为“read”的问题。
扫一扫
7984
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
