如何通过VBA实现从密码保护网站自动抓取数据至XLSM模板

一、自动登录+会话复用方案 #

由于URL内嵌凭据失败，可通过VBA自动化IE完成登录，让后续的QueryTable复用已登录会话，避免手动操作：

Sub AutoLoginAndScrape()
    Dim ie As Object
    Dim loginURL As String, targetURL As String
    Dim username As String, password As String
    
    ' 替换为实际内网地址
    loginURL = "https://Website.intranet.com/login"
    targetURL = "https://Website.intranet.com/allsites/"
    
    ' 安全获取凭据（避免硬编码）
    username = InputBox("请输入内网账号")
    password = InputBox("请输入内网密码")
    
    ' 初始化IE
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = False ' 调试时可改为True
    
    ' 完成登录流程
    ie.Navigate loginURL
    Do While ie.Busy Or ie.ReadyState <> 4: DoEvents: Loop
    
    ' 需根据登录页实际HTML元素调整选择器（按F12查看元素ID/名称）
    ie.Document.getElementById("username").Value = username
    ie.Document.getElementById("password").Value = password
    ie.Document.getElementById("login-submit").Click
    
    ' 等待登录跳转完成
    Do While ie.Busy Or ie.ReadyState <> 4: DoEvents: Loop
    
    ' 清理旧查询表，避免重复导入
    CleanupOldQuery
    
    ' 精简版QueryTable抓取数据
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & targetURL, Destination:=Range("$A$1"))
        .Name = "RFCMarket"
        .FieldNames = True
        .PreserveFormatting = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = True
        .AdjustColumnWidth = True
        .WebSelectionType = xlAllTables ' 如需指定单个表格，改为xlSpecifiedTables并设置.WebTables
        .WebFormatting = xlWebFormattingNone
        .Refresh BackgroundQuery:=False
    End With
    
    ' 关闭IE并释放资源
    ie.Quit
    Set ie = Nothing
    
    ' 执行自定义数据筛选
    FilterTargetData
End Sub

' 清理同名旧查询表
Sub CleanupOldQuery()
    Dim qt As QueryTable
    For Each qt In ActiveSheet.QueryTables
        If qt.Name = "RFCMarket" Then
            qt.Delete
            Exit For
        End If
    Next qt
End Sub

' 自定义数据筛选示例（按需修改）
Sub FilterTargetData()
    Dim lastRow As Long
    lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 示例：筛选第3列包含"有效"的行
    ActiveSheet.Range("A1:" & Cells(lastRow, Columns.Count).Address).AutoFilter _
        Field:=3, Criteria1:="*有效*", Operator:=xlAnd
End Sub

二、代码说明 #

• 自动登录：模拟手动登录流程，需根据内网登录页的HTML元素调整输入框、按钮的选择器（不懂HTML可按F12查看元素ID）。
• QueryTable精简：移除了冗余默认设置（如RowNumbers、FillAdjacentFormulas等，默认值已符合需求）。
• 凭据安全：用InputBox动态获取凭据，避免硬编码风险；如需长期保存，可结合Excel密码保护或Windows凭据管理器。
• 数据筛选：内置筛选示例，可根据实际需求修改筛选列、条件。

三、替代方案：WinHTTP直接请求 #

若IE自动化不稳定，可改用WinHTTPRequest传递凭据直接获取HTML，再提取表格数据：

Sub WinHTTPWebScrape()
    Dim http As Object
    Dim html As Object
    Dim targetURL As String
    Dim username As String, password As String
    
    targetURL = "https://Website.intranet.com/allsites/"
    username = InputBox("请输入内网账号")
    password = InputBox("请输入内网密码")
    
    Set http = CreateObject("WinHTTP.WinHTTPRequest.5.1")
    http.Open "GET", targetURL, False
    ' 适配基本认证/NTLM认证，根据内网类型调整
    http.SetCredentials username, password, 0 ' 0=基本认证，1=NTLM认证
    http.Send
    
    ' 解析HTML并提取第一个表格
    Set html = CreateObject("HTMLFile")
    html.Write http.ResponseText
    
    Dim table As Object, row As Object, cell As Object
    Dim r As Integer, c As Integer
    r = 1
    Set table = html.getElementsByTagName("table")(0)
    
    For Each row In table.Rows
        c = 1
        For Each cell In row.Cells
            ActiveSheet.Cells(r, c).Value = cell.innerText
            c = c + 1
        Next cell
        r = r + 1
    Next row
    
    ' 执行筛选
    FilterTargetData
End Sub

注意事项 #

• 内网若使用SSO单点登录，优先选择IE自动化方案，WinHTTP无法处理复杂跳转认证。
• 测试时将ie.Visible设为True，可直观排查登录流程是否正常。
• 文件需保存为XLSM格式，确保Excel启用宏功能。

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