如何解决在 VBA 中抓取谷歌搜索结果
我正在尝试根据关键字搜索 google,并在电子表格中列出网站标题、URL 和元描述。该代码运行并进行搜索,但它没有在我的电子表格中列出任何条目。几年前这曾经工作得很好,但我不确定现在发生了什么。有什么想法吗?
Sub pDownloadfromGoogle()
Dim tbl As Object
Dim lngLoop As Long
Dim objhtml As Object
Dim strLink As String
Dim varData As Variant
Dim objIE As Object
Dim strTitle As String
Dim strURL As String
Dim strDescription As String
Dim obj_g_Loop As Object
Dim obj_tbl As Object
Dim objR As Object
Dim objR_Loop As Object
Dim lngLastRow As Long
Dim strCom1 As String
Dim strCom2 As String
Dim strCom3 As String
Dim lngCtr As Long
Dim objNextPage As Object
Application.DisplayAlerts = False
Application.DisplayAlerts = False
strCom1 = Sheet2.Range("B1").Value & "+" & Sheet2.Range("C1").Value & "+" & Sheet2.Range("D1").Value
strCom2 = Sheet2.Range("C1").Value & "+" & Sheet2.Range("D1").Value & "+" & Sheet2.Range("B1").Value
strCom3 = Sheet2.Range("D1").Value & "+" & Sheet2.Range("B1").Value & "+" & Sheet2.Range("C1").Value
varData = Array(strCom1,strCom2,strCom3)
L = Sheet1.Cells(Sheet1.Rows.Count,"C").End(xlUp).Row + 1
Sheet1.Range("C2:F" & L).ClearContents
For lngLoop = 0 To UBound(varData)
Set objIE = CreateObject("InternetExplorer.Application")
With objIE
.Visible = False
.navigate "https://www.google.com/search?q=" & varData(lngLoop)
Do While .busy 'Or .readyState <> 4
DoEvents
Application.Wait DateAdd("s",1,Now)
Loop
End With
LoopAgain:
On Error Resume Next
Set obj_tbl = objIE.document.getElementsByClassName("g")
I = 1
L = 1
For Each obj_g_Loop In obj_tbl
L = Sheet1.Cells(Sheet1.Rows.Count,"C").End(xlUp).Row + 1
Set objR = obj_g_Loop.getElementsByClassName("r")
strTitle = objR(0).innertext
strURL = objR(0).getElementsByTagName("a")(0).href
Set objR = obj_g_Loop.getElementsByClassName("st")
strDescription = objR(0).innertext
Sheet1.Cells(L,"C") = strTitle
Sheet1.Cells(L,"D") = strURL
Sheet1.Cells(L,"E") = strDescription
Set objR = Nothing
strTitle = ""
strURL = ""
strDescription = ""
Next obj_g_Loop
lngCtr = lngCtr + 1
If lngCtr < 3 Then
Set objNextPage = objIE.document.getElementByid("pnnext")
objNextPage.Click
Application.Wait (Now + TimeValue("0:00:5"))
GoTo LoopAgain
End If
' Stop
objIE.Quit
lngCtr = 0
Next lngLoop
Sheet1.Range("$C$1:$E$" & L).RemoveDuplicates Columns:=2,Header:=xlYes
MsgBox "Process Complete!"
Application.DisplayAlerts = True
Application.DisplayAlerts = True
End Sub
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。