如何用VBA发起GET请求抓取指定日期段的俄罗斯央行指定汇率数据

核心逻辑说明 #

• 替换原有硬编码日期的写法，通过循环遍历指定时间范围内的所有日期
• 无需每次生成新工作表存储全量页面数据，仅提取目标行数据写入统一汇总表，大幅降低冗余操作
• 自动适配接口要求的DD.MM.YYYY格式日期参数

完整可运行代码 #

Sub BatchGetCBRRate()
    ' 配置参数，可根据需求修改
    Const targetRow As Integer = 45 ' 目标货币所在行号
    Dim startDate As Date, endDate As Date
    startDate = DateSerial(2021, 7, 1) ' 起始日期：年/月/日
    endDate = DateSerial(2021, 7, 10) ' 结束日期：年/月/日
    
    ' 初始化汇总表
    Dim wsSum As Worksheet
    Set wsSum = ThisWorkbook.Sheets(1)
    wsSum.Cells.Clear
    Dim writeRow As Integer
    writeRow = 1 ' 写入起始行
    
    ' 循环遍历所有日期
    Dim curDate As Date
    For curDate = startDate To endDate
        ' 格式化日期为接口要求的DD.MM.YYYY格式
        Dim dateStr As String
        dateStr = Format(curDate, "DD.MM.YYYY")
        
        ' 临时工作表存储单天查询结果
        Dim wsTemp As Worksheet
        Set wsTemp = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        
        ' 发送GET请求拉取页面数据
        With wsTemp.QueryTables.Add(Connection:= _
            "URL;https://cbr.ru/currency_base/daily/?UniDbQuery.Posted=True&UniDbQuery.To=" & dateStr, _
            Destination:=wsTemp.Range("A1"))
            .CommandType = 0
            .Name = "CBRRate_" & dateStr
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        
        ' 提取目标行数据写入汇总表
        wsSum.Cells(writeRow, 1) = curDate ' 第一列存对应日期
        wsTemp.Rows(targetRow).Copy Destination:=wsSum.Cells(writeRow, 2)
        writeRow = writeRow + 1
        
        ' 删除临时工作表，关闭提示
        Application.DisplayAlerts = False
        wsTemp.Delete
        Application.DisplayAlerts = True
        
        ' 避免请求频率过高被限制
        Application.Wait Now + TimeValue("00:00:01")
    Next curDate
    
    ' 自动调整汇总表列宽
    wsSum.Columns.AutoFit
    MsgBox "汇率数据拉取完成，共获取" & writeRow - 1 & "条数据"
End Sub

使用注意事项 #

1. 运行前修改代码中startDate和endDate为你需要查询的起止日期
2. 如果目标货币对应的行号有变动，修改targetRow常量的数值即可
3. 代码默认每次请求间隔1秒，可根据实际运行情况调整间隔时长
4. 所有汇总结果默认保存在工作簿的第一个工作表中，第一列为对应查询日期

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