如何编写VBA代码抓取网页近4周表格数据并合并？

• 需求：抓取网页https://www.lottoraden.se/resultat/maltipset/的近4周表格数据，并合并到Excel工作表中。
• 问题：尝试通过循环将日期每周减7天生成对应URL，调用Web.BrowserContents获取数据，但现有查询逻辑存在问题，无法正常采集4周数据。

用户提供的原尝试代码：

For I=1 to 4
Source = Web.BrowserContents("https://www.lottoraden.se/resultat/maltipset/" & NewDate) 
NewDate= NewDate-7
Next I

现有VBA代码：

Sub getdata()

    ActiveWorkbook.Queries.Add Name:="Table 4", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Web.BrowserContents(""https://www.lottoraden.se/resultat/maltipset/2025-03-22"")," & Chr(13) & "" & Chr(10) & "    #""Extracted Table From Html"" = Html.Table(Source, {{""Column1"", "".item-number""}, {""Column2"", "".item-name""}, {""Column3"", "".item-state""}, {""Column4"", "".active:nth-child(1)""}}, [RowSelector="".content-table-row""])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.Tr" & _
        "ansformColumnTypes(#""Extracted Table From Html"",{{""Column1"", Int64.Type}, {""Column2"", type text}, {""Column3"", Int64.Type}, {""Column4"", Int64.Type}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 4"";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Table 4]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Table_4"
        .Refresh BackgroundQuery:=False
    End With
End Sub

方案一：Power Query M语言实现（推荐） #

Power Query原生支持批量数据抓取与合并，无需复杂循环，直接生成目标日期列表后批量请求并合并结果：

let
    // 生成近4周的日期（从今天开始，每周往前推7天）
    DateList = List.Dates(Date.From(DateTime.LocalNow()), 4, #duration(-7, 0, 0, 0)),
    // 将日期格式化为网页要求的YYYY-MM-DD格式
    FormattedDates = List.Transform(DateList, each Date.ToText(_, "yyyy-MM-dd")),
    // 定义获取单天数据的函数
    GetSingleDayData = (dateStr as text) =>
        let
            // 获取指定日期的网页内容
            Source = Web.BrowserContents("https://www.lottoraden.se/resultat/maltipset/" & dateStr),
            // 提取HTML表格
            ExtractedTable = Html.Table(Source, 
                {{"序号", ".item-number"}, {"名称", ".item-name"}, {"状态值", ".item-state"}, {"数值", ".active:nth-child(1)"}}, 
                [RowSelector=".content-table-row"]),
            // 添加开奖日期列，方便区分不同周的数据
            AddDateColumn = Table.AddColumn(ExtractedTable, "开奖日期", each dateStr)
        in
            AddDateColumn,
    // 对所有日期应用获取数据的函数
    AllRawData = List.Transform(FormattedDates, GetSingleDayData),
    // 合并所有日期的表格
    CombinedTable = Table.Combine(AllRawData),
    // 调整各列数据类型
    FinalTable = Table.TransformColumnTypes(CombinedTable, {
        {"序号", Int64.Type}, 
        {"名称", type text}, 
        {"状态值", Int64.Type}, 
        {"数值", Int64.Type}, 
        {"开奖日期", type date}
    })
in
    FinalTable

使用步骤： #

1. 打开Excel，点击数据选项卡 → 获取数据 → 自其他来源 → 空白查询
2. 在Power Query编辑器中，点击高级编辑器，替换原有代码为上述M语言代码
3. 点击关闭并上载，合并后的近4周数据会自动导入到新工作表中

方案二：改进后的VBA实现 #

对原VBA代码进行优化，通过循环生成目标日期，逐个抓取数据并合并到同一个工作表：

Sub GetMaltipset4WeeksData()
    Dim targetWs As Worksheet
    Dim startDate As Date
    Dim currentDate As Date
    Dim dateStr As String
    Dim queryName As String
    Dim lastRow As Long
    Dim i As Integer
    
    ' 创建新工作表用于存放合并后的数据
    Set targetWs = ThisWorkbook.Worksheets.Add
    targetWs.Name = "Maltipset近4周数据"
    
    ' 起始日期设为当前日期，如需指定日期可改为DateSerial(2025, 3, 22)
    startDate = Date
    currentDate = startDate
    
    ' 循环抓取近4周数据
    For i = 1 To 4
        dateStr = Format(currentDate, "yyyy-mm-dd")
        queryName = "TempQuery_" & dateStr
        
        ' 删除已存在的同名临时查询
        On Error Resume Next
        ThisWorkbook.Queries(queryName).Delete
        On Error GoTo 0
        
        ' 添加Power Query查询获取单天数据
        ThisWorkbook.Queries.Add Name:=queryName, Formula:= _
            "let" & Chr(13) & "" & Chr(10) & _
            "    Source = Web.BrowserContents(""https://www.lottoraden.se/resultat/maltipset/" & dateStr & """)," & Chr(13) & "" & Chr(10) & _
            "    #""提取表格"" = Html.Table(Source, {{""Column1"", "".item-number""}, {""Column2"", "".item-name""}, {""Column3"", "".item-state""}, {""Column4"", "".active:nth-child(1)""}}, [RowSelector="".content-table-row""])," & Chr(13) & "" & Chr(10) & _
            "    #""添加日期列"" = Table.AddColumn(#""提取表格"", ""开奖日期"", """ & dateStr & """)," & Chr(13) & "" & Chr(10) & _
            "    #""调整数据类型"" = Table.TransformColumnTypes(#""添加日期列"",{{""Column1"", Int64.Type}, {""Column2"", type text}, {""Column3"", Int64.Type}, {""Column4"", Int64.Type}, {""开奖日期"", type date}})" & Chr(13) & "" & Chr(10) & _
            "in" & Chr(13) & "" & Chr(10) & "    #""调整数据类型"""
        
        ' 将查询数据导入目标工作表
        lastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 And targetWs.Cells(1, 1).Value = "" Then
            ' 首次导入保留表头
            With targetWs.ListObjects.Add(SourceType:=0, Source:= _
                "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""" & queryName & """;Extended Properties=""""" _
                , Destination:=targetWs.Range("$A$1")).QueryTable
                .CommandType = xlCmdSql
                .CommandText = Array("SELECT * FROM [" & queryName & "]")
                .Refresh BackgroundQuery:=False
            End With
        Else
            ' 后续导入跳过表头
            With targetWs.QueryTables.Add(Connection:= _
                "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""" & queryName & """;Extended Properties=""""" _
                , Destination:=targetWs.Range("A" & lastRow + 1))
                .CommandType = xlCmdSql
                .CommandText = Array("SELECT * FROM [" & queryName & "]")
                .RefreshStyle = xlInsertDeleteCells
                .Refresh BackgroundQuery:=False
                .Delete ' 导入后删除临时查询表
            End With
        End If
        
        ' 日期往前推7天
        currentDate = currentDate - 7
    Next i
    
    ' 清理所有临时查询
    For Each q In ThisWorkbook.Queries
        If Left(q.Name, 9) = "TempQuery_" Then q.Delete
    Next q
    
    MsgBox "近4周数据抓取合并完成！"
End Sub

注意事项： #

• 确保Excel已启用Power Query功能（数据选项卡可见“获取数据”按钮）
• 首次运行时可能需要授权Excel访问目标网页
• 若需从指定日期开始抓取，修改startDate = Date为startDate = DateSerial(年, 月, 日)即可

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