请求编写VBA代码抓取CME黄金页面PRELIMINARY DATA表格

问题说明 #

需要编写VBA代码抓取网页CME黄金成交量页面中PRELIMINARY DATA板块的表格数据。此前使用适用于印度NSE交易所页面的VBA代码无法在该页面生效，寻求技术解决。

原尝试代码（适用于NSE页面） #

Sub GetTableUsingIE_From_NSE() 'Working sample code for NSE Website table
    'Refer below website for further nested code of row col
    'https://copyprogramming.com/howto/how-to-extract-data-from-website-with-vba-excel
    
    Dim ieApp As Object
    Dim url As String
    Dim htmlDoc As Object
    Dim tables As Object
    Dim table As Object
    
    ' Specify the URL of the website
    
    url = "https://www.nseindia.com/market-data/live-equity-market"
    'url = "https://www.cmegroup.com/markets/metals/precious/gold.volume.html#tradeDate=20231212"
    ' Create a new instance of Internet Explorer
    Set ieApp = CreateObject("InternetExplorer.Application")
    
    ' Make IE visible (you can set it to False if you don't want to see the browser)
    ieApp.Visible = True
    
    ' Navigate to the specified URL
    ieApp.navigate url
    
    ' Wait for the page to load (you may need to adjust the wait time based on the website)
    Do While ieApp.Busy Or ieApp.readyState <> 4
        Application.Wait Now + TimeValue("0:00:03")
    Loop
    
    ' Get the HTML document from the loaded page
    Set htmlDoc = ieApp.document
    
'    ' Get all tables from the HTML document
'    Set tables = htmlDoc.getElementsByTagName("table")
'
'    ' Loop through each table and do something (e.g., print table contents)
'    For Each table In tables
'        ' Do something with the table, e.g., print its innerHTML
'        Debug.Print table.innerHTML
'        MsgBox table.innerHTML
'    Next table
    Dim elt As Object
    Dim aRow, aCol, totCol As Integer
    Dim sHeaderStr  As String
    ThisWorkbook.Sheets("Data").UsedRange.Clear
    With htmlDoc.getElementsByTagName("table").Item(0)
        
        aRow = 1
        aCol = 1
        For Each elt In .getElementsByTagName("th")
            Debug.Print elt.innerText
            sHeaderStr = elt.innerText
            ThisWorkbook.Sheets("Data").Cells(aRow, aCol).Value = sHeaderStr
            aCol = aCol + 1
            totCol = aCol
        Next elt
        aRow = aRow + 1
        aCol = 1
        Debug.Print vbNewLine
        For Each elt In .getElementsByTagName("td") '        
            Debug.Print elt.innerText
            ThisWorkbook.Sheets("Data").Cells(aRow, aCol).Value = elt.innerText
            If aCol < 18 Then
                aCol = aCol + 1
            Else
                aCol = 1
                aRow = aRow + 1
            End If
        
        Next elt
    End With
    ThisWorkbook.Sheets("Data").UsedRange.Rows.AutoFit
    ThisWorkbook.Sheets("Data").UsedRange.Rows.WrapText = True
    ThisWorkbook.Sheets("Data").UsedRange.Rows.WrapText = False
    
    ' Close Internet Explorer
    ieApp.Quit
    Set ieApp = Nothing
End Sub

原代码失效原因 #

1. 表格定位错误：原代码直接取页面第一个表格（getElementsByTagName("table").Item(0)），但CME页面中PRELIMINARY DATA表格并非页面首个表格，直接定位会抓取错误内容。
2. 加载逻辑不匹配：CME页面表格为动态渲染内容，原代码的固定等待时间不足以确保数据完全加载。
3. 列数硬编码：原代码中If aCol < 18是针对NSE页面的硬编码，CME目标表格列数不同，会导致数据排版错乱。

修改后的VBA代码（适配CME页面） #

Sub GetCMEGoldPreliminaryData()
    Dim ieApp As Object
    Dim url As String
    Dim htmlDoc As Object
    Dim targetTable As Object
    Dim rowElements As Object, rowElement As Object
    Dim cellElements As Object, cellElement As Object
    Dim destSheet As Worksheet
    Dim rowNum As Integer, colNum As Integer
    
    ' 设置目标URL
    url = "https://www.cmegroup.com/markets/metals/precious/gold.volume.html#tradeDate=20231212"
    
    ' 初始化IE对象
    Set ieApp = CreateObject("InternetExplorer.Application")
    ieApp.Visible = True ' 调试时可视，发布后可改为False
    ieApp.navigate url
    
    ' 等待页面加载完成，增加动态响应逻辑
    Do While ieApp.Busy Or ieApp.readyState <> 4
        DoEvents
    Loop
    ' 额外等待动态内容渲染
    Application.Wait Now + TimeValue("0:00:05")
    
    Set htmlDoc = ieApp.document
    
    ' 通过Class属性定位PRELIMINARY DATA板块的表格
    Set targetTable = htmlDoc.querySelector(".table.table-header-borders.table-row-light")
    
    If targetTable Is Nothing Then
        MsgBox "未找到目标表格，请检查页面结构是否更新"
        ieApp.Quit
        Set ieApp = Nothing
        Exit Sub
    End If
    
    ' 初始化目标工作表
    Set destSheet = ThisWorkbook.Sheets("Data")
    destSheet.UsedRange.Clear
    rowNum = 1
    
    ' 逐行读取表格数据（表头+内容）
    Set rowElements = targetTable.getElementsByTagName("tr")
    For Each rowElement In rowElements
        ' 处理表头行
        If rowElement.getElementsByTagName("th").Length > 0 Then
            colNum = 1
            Set cellElements = rowElement.getElementsByTagName("th")
            For Each cellElement In cellElements
                destSheet.Cells(rowNum, colNum).Value = cellElement.innerText
                colNum = colNum + 1
            Next cellElement
            rowNum = rowNum + 1
        ' 处理数据行
        ElseIf rowElement.getElementsByTagName("td").Length > 0 Then
            colNum = 1
            Set cellElements = rowElement.getElementsByTagName("td")
            For Each cellElement In cellElements
                destSheet.Cells(rowNum, colNum).Value = cellElement.innerText
                colNum = colNum + 1
            Next cellElement
            rowNum = rowNum + 1
        End If
    Next rowElement
    
    ' 格式化工作表
    destSheet.UsedRange.Columns.AutoFit
    
    ' 关闭IE并释放资源
    ieApp.Quit
    Set ieApp = Nothing
    MsgBox "数据抓取完成"
End Sub

代码关键说明 #

• 精准定位：使用querySelector通过表格的Class属性定位目标表格，避免因页面表格顺序变化导致抓取错误。
• 优化等待逻辑：增加DoEvents让程序响应系统事件，额外等待5秒确保动态加载的表格数据完全渲染。
• 自适应行列：不再硬编码列数，根据表格实际行、单元格数量循环读取，适配目标表格结构。
• 错误处理：增加表格不存在的判断，避免程序崩溃。

内容的提问来源于stack exchange，提问作者Max