麻辣家族討論版版 - Powered by Discuz! Board

Public a As Boolean
Sub StartTimer()
Range("E7") = "自動更新：開啟"
If a = True Then End
DoEvents
Application.OnTime Now + TimeValue("00:00:01"), "StartTimer2", Schedule:=True
End Sub
Sub StartTimer2()
DoEvents
Call NewsOne '你的SUB
Call StartTimer
End Sub
Sub StopTimer()
a = IIf(a = True, False, True)
Range("E7") = "自動更新：關閉"
On Error Resume Next
Application.OnTime Now + TimeValue("00:00:05"), "StartTimer2", Schedule:=False
End Sub
Sub NewsOne()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cookie As String
Dim result_cookie As String
start_time = Time
Debug.Print "start_time:" & start_time
For i = 1 To lastRow
url = "https://www.google.co.in/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 objH3 = objResultDiv.getelementsbytagname("H3")(0)
Set link = objH3.getelementsbytagname("a")(0)
str_text = Replace(link.innerHTML, "<EM>", "")
str_text = Replace(str_text, "</EM>", "")
Cells(i, 7) = str_text
Cells(i, 8) = link.href
DoEvents
Next
end_time = Time
Debug.Print "end_time:" & end_time
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
'MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

複製代碼