Excel宏与VBA网页查询脚本故障求助：无法遍历网址列表

原代码核心问题 #

• 嵌套循环（For x + Do Until）逻辑冲突，导致循环提前终止或重复遍历
• 行数计算逻辑错误，无法正确获取网址列表的总行数
• 过度依赖ActiveCell和Select，切换工作表后操作对象错位（误在新工作表执行原表的列隐藏、单元格赋值操作）
• 查询名称queryName包含网址中的非法字符（如/、:），触发查询创建失败
• 未声明变量i，触发编译错误
• 数据验证范围错误，误操作新工作表的A列而非原表目标列

修复后的代码 #

Sub ImportWebTables()
    ' 快捷键: Ctrl+Shift+Q
    Dim wsSource As Worksheet
    Dim newSheet As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim queryName As String
    Dim queryFormula As String
    Dim cleanUrlName As String
    
    Set wsSource = ActiveSheet
    ' 获取A列从A2开始的最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A2到最后一行的每个网址
    For Each cell In wsSource.Range("A2:A" & lastRow)
        ' 跳过空单元格或已处理的行（B列有内容）
        If cell.Value = "" Or Not IsEmpty(cell.Offset(0, 1).Value) Then GoTo NextCell
        
        ' 清理网址中的非法字符，作为查询名称的一部分
        cleanUrlName = Replace(Replace(Replace(cell.Value, "https://", ""), "/", "_"), ":", "_")
        queryName = "Query_" & Format(Now, "YYYYMMDD_HHMMSS") & "_" & cleanUrlName
        
        ' 创建Power Query公式
        queryFormula = "let" & vbCrLf & _
            "    Source = Web.BrowserContents(""" & cell.Value & """), " & vbCrLf & _
            "    #""Extracted Table From Html"" = Html.Table(Source, {{" & _
            """Column1"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(1)""}, " & _
            """Column2"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(2)""}, " & _
            """Column3"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(3)""}, " & _
            """Column4"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(4)""}, " & _
            """Column5"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(5)""}, " & _
            """Column6"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(6)""}, " & _
            """Column7"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(7)""}, " & _
            """Column8"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(8)""}, " & _
            """Column9"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(9)""}, " & _
            """Column10"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(10)""}, " & _
            """Column11"", ""TABLE[id='js-checklist'] > * > TR > :nth-child(11)""}}, " & _
            "[RowSelector=""TABLE[id='js-checklist'] > * > TR""])," & vbCrLf & _
            "    #""Promoted Headers"" = Table.PromoteHeaders(#""Extracted Table From Html"", [PromoteAllScalars=true])," & vbCrLf & _
            "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"", {{" & _
            """Set"", type text}, {""?"", type text}, {""Name ?"", type text}, {""Cost"", type text}, " & _
            """Type"", type text}, {""R"", type text}, {""La"", type text}, {""Artist"", type text}, " & _
            """USD"", Currency.Type}, {""EUR"", type text}, {""TIX"", type number}})" & vbCrLf & _
            "in" & vbCrLf & _
            "    #""Changed Type"""
        
        ' 创建查询，捕获错误
        On Error Resume Next
        ActiveWorkbook.Queries.Add Name:=queryName, Formula:=queryFormula
        If Err.Number <> 0 Then
            MsgBox "创建查询失败: " & Err.Description & vbCrLf & "网址: " & cell.Value
            Err.Clear
            GoTo NextCell
        End If
        On Error GoTo 0
        
        ' 添加新工作表并加载查询数据
        Set newSheet = ThisWorkbook.Sheets.Add(After:=wsSource)
        With newSheet.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""" & queryName & """;Extended Properties=""""" _
            , Destination:=newSheet.Range("$A$1")).QueryTable
            .CommandType = xlCmdSql
            .CommandText = Array("SELECT * FROM [" & queryName & "]")
            .BackgroundQuery = False
            .RefreshStyle = xlInsertDeleteCells
            .AdjustColumnWidth = True
            .PreserveColumnInfo = True
            .ListObject.DisplayName = "Table_" & cleanUrlName
            .Refresh BackgroundQuery:=False
        End With
        
        ' 回到原工作表执行后续操作
        wsSource.Activate
        ' 隐藏指定列（修正原无效列逻辑，改为隐藏A、B、C列，可按需调整）
        Dim i As Integer
        For i = 0 To 2
            cell.Offset(0, i).EntireColumn.Hidden = True
        Next i
        
        ' 写入CAD和Quantity（处理A列左侧无列的情况）
        On Error Resume Next
        cell.Offset(0, -1).Value = "CAD"
        If Err.Number <> 0 Then
            cell.Offset(0, 2).Value = "CAD"
            Err.Clear
        End If
        On Error GoTo 0
        cell.Offset(0, 1).Value = "Quantity"
        
        ' 给Quantity列添加数据验证
        With cell.Offset(0, 1).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1,2,3,4,5,6,7,8,9,10"
            .IgnoreBlank = True
            .InCellDropdown = True
            .ShowInput = True
            .ShowError = True
        End With
        
NextCell:
    Next cell
End Sub

关键修复点说明 #

1. 简化循环逻辑：用For Each直接遍历A列网址范围，消除嵌套循环冲突
2. 修正行数计算：通过Rows.Count精准获取最后一行，确保遍历所有有效网址
3. 避免ActiveCell依赖：直接使用cell对象引用原表单元格，切换工作表后重新激活原表再操作
4. 清理查询名称：替换网址中的非法字符，避免查询创建失败
5. 添加错误捕获：对查询创建、单元格赋值等易出错步骤增加错误处理，防止宏崩溃
6. 声明所有变量：添加Dim i As Integer，符合VBA编码规范
7. 修正数据验证范围：直接对原表的Quantity列（对应B列行）添加验证，避免误操作新表

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