我有一個包含大約 25,000 個公司關鍵字的 Excel 工作簿，我想從中獲取公司網站 URL。我希望運行一個 VBA 腳本，該腳本可以將這些關鍵字作為 Google 搜索來運行，并將第一個結果的 URL 拉入電子表格中。我發現了一個類似的線程。這樣做的結果是偶然的；某些關鍵字會在下一列中返回 URL，其他關鍵字則保留空白。它還似乎在第一個搜索結果中提取了 Google 優化子鏈接的 URL，而不是主網站 URL：Google 搜索結果示例然后我在這里找到了下面的代碼，我在包含 1,000 個關鍵字的示例列表上運行了該代碼。該博客的作者規定該代碼適用于 Mozilla Firefox。我測試了他也編寫的 IE 代碼，但這并沒有達到相同的結果（它添加了由搜索結果中的描述性文本組成的超鏈接，而不是原始 URL）。Firefox 代碼一直運行到第 714行，然后返回錯誤消息“運行時錯誤 91：未設置對象變量或 with 塊變量”顯示成功結果和宏停止的行的電子表格布局Sub GoogleURL () Dim url As String, lastRow As Long Dim XMLHTTP As Object Dim html As Object Dim objResultDiv As Object Dim objH As Object lastRow = Range(“A” & Rows.Count).End(xlUp).Row For i = 2 To lastRow url = “https://www.google.co.uk/search?q=” & Cells(i, 1) & “&rnd=” & WorksheetFunction.RandBetween(1, 10000) Set XMLHTTP = CreateObject(“MSXML2.serverXMLHTTP”) XMLHTTP.Open “GET”, url, False XMLHTTP.setRequestHeader “Content-Type”, “text/xml” XMLHTTP.setRequestHeader “User-Agent”, “Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0” XMLHTTP.send Set html = CreateObject(“htmlfile”) html.body.innerHTML = XMLHTTP.ResponseText Set objResultDiv = html.getelementbyid(“rso”) Set objH = objResultDiv.getelementsbytagname(“h3”)(0) Cells(i, 2).Value = objH.innerText Set html = CreateObject(“htmlfile”) html.body.innerHTML = XMLHTTP.ResponseText Set objResultDiv = html.getelementbyid(“rso”) Set objH = objResultDiv.getelementsbytagname(“cite”)(0) Cells(i, 3).Value = objH.innerText DoEvents NextEnd Sub
1 回答
九州編程
TA貢獻1785條經驗 獲得超4個贊
由于Firefox是微軟支持范圍內的第三方瀏覽器，我可以幫你查看IE瀏覽器的VBA代碼。
您的要求是將描述和鏈接存儲在單獨的列中。
我嘗試根據您的要求修改該示例代碼。
這是該示例的修改后的代碼。
Option Explicit
Const TargetItemsQty = 1 ' results for each keyword
Sub GWebSearchIECtl()
? ? Dim objSheet As Worksheet
? ? Dim objIE As Object
? ? Dim x As Long
? ? Dim y As Long
? ? Dim strSearch As String
? ? Dim lngFound As Long
? ? Dim st As String
? ? Dim colGItems As Object
? ? Dim varGItem As Variant
? ? Dim strHLink As String
? ? Dim strDescr As String
? ? Dim strNextURL As String
? ? Set objSheet = Sheets("Sheet1")
? ? Set objIE = CreateObject("InternetExplorer.Application")
? ? objIE.Visible = True ' for debug or captcha request cases
? ? y = 1 ' start searching for the keyword in the first row
? ? With objSheet
? ? ? ? .Select
? ? ? ? .Range(.Columns("B:B"), .Columns("B:B").End(xlToRight)).Delete ' clear previous results
? ? ? ? .Range(.Columns("C:C"), .Columns("C:C").End(xlToRight)).Delete ' clear previous results
? ? ? ? .Range("A1").Select
? ? ? ? Do Until .Cells(y, 1) = ""
? ? ? ? ? ? x = 2 ' start writing results from column B
? ? ? ? ? ? .Cells(y, 1).Select
? ? ? ? ? ? strSearch = .Cells(y, 1) ' current keyword
? ? ? ? ? ? With objIE
? ? ? ? ? ? ? ? lngFound = 0
? ? ? ? ? ? ? ? .navigate "https://www.google.com/search?q=" & EncodeUriComponent(strSearch) ' go to first search results page
? ? ? ? ? ? ? ? Do
? ? ? ? ? ? ? ? ? ? Do While .Busy Or Not .READYSTATE = 4: DoEvents: Loop ' wait IE
? ? ? ? ? ? ? ? ? ? Do Until .document.READYSTATE = "complete": DoEvents: Loop ' wait document
? ? ? ? ? ? ? ? ? ? Do While TypeName(.document.getelementbyid("res")) = "Null": DoEvents: Loop ' wait [#res] element
? ? ? ? ? ? ? ? ? ? Set colGItems = .document.getelementbyid("res").getElementsByClassName("g") ' collection of search result [.g] items
? ? ? ? ? ? ? ? ? ? For Each varGItem In colGItems ' process each item in collection
? ? ? ? ? ? ? ? ? ? ? ? If varGItem.getelementsbytagname("a").Length > 0 And varGItem.getElementsByClassName("st").Length > 0 Then ' must have hyperlink and description
? ? ? ? ? ? ? ? ? ? ? ? ? ? strHLink = varGItem.getelementsbytagname("a")(0).href ' get first hyperlink [a] found in current item
? ? ? ? ? ? ? ? ? ? ? ? ? ? strDescr = GetInnerText(varGItem.getElementsByClassName("st")(0).innerHTML) ' get first description [span.st] found in current item
? ? ? ? ? ? ? ? ? ? ? ? ? ? lngFound = lngFound + 1
? ? ? ? ? ? ? ? ? ? ? ? ? ? 'Debug.Print (strHLink)
? ? ? ? ? ? ? ? ? ? ? ? ? ? 'Debug.Print (strDescr)
? ? ? ? ? ? ? ? ? ? ? ? ? ? With objSheet ' put result into cell
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?.Cells(y, x).Value = strDescr
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?.Hyperlinks.Add .Cells(y, x + 1), strHLink
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? .Cells(y, x).WrapText = True
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? x = x + 1 ' next column
? ? ? ? ? ? ? ? ? ? ? ? ? ? End With
? ? ? ? ? ? ? ? ? ? ? ? ? ? If lngFound = TargetItemsQty Then Exit Do ' continue with next keyword - necessary quantity of the results for current keyword found
? ? ? ? ? ? ? ? ? ? ? ? End If
? ? ? ? ? ? ? ? ? ? ? ? DoEvents
? ? ? ? ? ? ? ? ? ? Next
? ? ? ? ? ? ? ? ? ? If TypeName(.document.getelementbyid("pnnext")) = "Null" Then Exit Do ' continue with next keyword - no [a#pnnext.pn] next page button exists
? ? ? ? ? ? ? ? ? ? strNextURL = .document.getelementbyid("pnnext").href ' get next page url
? ? ? ? ? ? ? ? ? ? .navigate strNextURL ' go to next search results page
? ? ? ? ? ? ? ? Loop
? ? ? ? ? ? End With
? ? ? ? ? ? y = y + 1 ' next row
? ? ? ? Loop
? ? End With
? ? objIE.Quit
? ? ' google web search page contains the elements:
? ? ' [div#res] - main search results block
? ? ' [div.g] - each result item block within [div#res]
? ? ' [a] - hyperlink ancor(s) within each [div.g]
? ? ' [span.st] - description(s) within each [div.g]
? ? ' [a#pnnext.pn] - hyperlink ancor to the next search results page
End Sub
Function EncodeUriComponent(strText As String) As String
? ? Static objHtmlfile As Object
? ? If objHtmlfile Is Nothing Then
? ? ? ? Set objHtmlfile = CreateObject("htmlfile")
? ? ? ? objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
? ? End If
? ? EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function
Function GetInnerText(strText As String) As String
? ? Static objHtmlfile As Object
? ? If objHtmlfile Is Nothing Then
? ? ? ? Set objHtmlfile = CreateObject("htmlfile")
? ? ? ? objHtmlfile.Open
? ? ? ? objHtmlfile.Write "<body></body>"
? ? End If
? ? objHtmlfile.body.innerHTML = strText
? ? GetInnerText = objHtmlfile.body.innerText
End Function
- 1 回答
- 0 關注
- 144 瀏覽
添加回答
舉報
0/150
提交
取消