时间戳

首页 > 解决方案 > 如何在 Excel 文档中使用 VBA 循环浏览超链接

excel - 如何在 Excel 文档中使用 VBA 循环浏览超链接

问题描述

我有一个大约的清单。一列中有 160 个 excel 超链接。我正在尝试从每个单独的链接中提取数据。为了导航到特定页面（例如https://www.oddschecker.com/golf/canadian-open/winner/bet-history/dustin-johnson）。

注意。出于测试目的，代码的范围很小。

我认为最好的流程是：

  1. 单击并打开每个单独的超链接
  2. 拉取资料
  3. 关闭网页
  4. 重复链接 2
  5. 重复链接 3

我在编写将单击并随后从一个链接“循环”到下一个链接的代码时遇到问题，例如从单元格 A6 到单元格 A7。

我尝试过使用涉及 .click 动作的 For each 循环。

不幸的是，我在上述方面没有取得任何成功。

如果可以提供一些帮助，或者如果有人可以指出我自己进一步调查的方向，那将不胜感激。

Public Sub GetReleaseTimes()

Dim ie As Object, hTable As HTMLTable, clipboard As Object, ws2 As Worksheet, ws1 As Worksheet, URL As Range
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ie = CreateObject("InternetExplorer.Application")
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With ie
    .Visible = True
    .navigate2 
     For Each URL In ws1.Range("A6:A10").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

    Set hTable = .document.querySelector(".eventTable")
    clipboard.SetText hTable.outerHTML
    clipboard.PutInClipboard
    ws2.Range("A1").PasteSpecial
    Next
    .Quit

    End With

End Sub

标签： excelvbainternet-explorerweb-scraping

解决方案

请不要点击超链接打开浏览器进行抓取。将链接读入一个数组，循环该数组并 .navigate2 每个 url。

此外，当您从剪贴板粘贴时，您需要每次都找到最后使用的行，而不考虑列，然后在每次旋转的下方粘贴一两行。

Option Explicit

Public Sub GetReleaseTimes()

    Dim ie As Object, hTable As HTMLTable, clipboard As Object
    Dim ws2 As Worksheet, ws1 As Worksheet, urls()

    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ie = CreateObject("InternetExplorer.Application")
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    urls = Application.Transpose(ws1.Range("A6:A10").Value)

    With ie
        .Visible = True

        For i = LBound(urls) To UBound(urls)
            .Navigate2 urls(i)
            While .Busy Or .readyState < 4: DoEvents: Wend

            Set hTable = .document.querySelector(".eventTable")
            clipboard.SetText hTable.outerHTML
            clipboard.PutInClipboard
            ws2.Range("A" & GetLastRow(ws2) + 2).PasteSpecial
        Next
        .Quit
    End With
End Sub
Public Function GetLastRow(ByVal sh As Worksheet) As Long
    On Error Resume Next
    GetLastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

推荐阅读