VBA help | INFJ Forum

VBA help

dogman6126

dogman6126

Community Member
May 9, 2014
811
213
602
MBTI
ENFJ-wasINFJ
Does anyone on here know VBA? I need help understanding why a Macro I wrote in excel isn't working right. This program is supposed to take what is in Cells(2, 7), run a google search, collect the resultstats, and record those stats in Cells(2, 4). Then shift down one line and run again until the cell is empty. The problem is I run into error 80070005, which from what I've read is because google doesn't let you do a lot of searches at a time. To get around this, I'm trying to program the code to on error change the XMLHTTP object and continue on the list. However, I keep running into an overflow error on the ErrCount = ErrCount + 1. I'm not sure why or how to avoid it. I'm only just now learning VBA, so I could really use some help. Any thoughts?

here's the code:

Sub GoogleSearchExcelResults()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object
Dim start_time As Date
Dim end_time As Date
Dim Selec1 As Object
Dim Selec2 As Object
Dim rowNo As Integer
Dim ErrCount As Integer


rowNo = 2
ErrCount = 1

Set Selec1 = Cells(rowNo, 7)
Set Selec2 = Cells(rowNo, 4)



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


Do Until Selec1.Value = ""

On Error GoTo XMLErr


Set Selec1 = Cells(rowNo, 7)
Set Selec2 = Cells(rowNo, 4)

url = "https://www.google.co.in/search?q=" & Selec1 & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)

Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
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

If html.getElementById("resultStats") Is Nothing Then
str_text = "0 Results"
Else
str_text = html.getElementById("resultStats").innerText
End If

Selec2 = str_text

rowNo = rowNo + 1

XMLErr: If Err Then ErrCount = ErrCount + 1


If ErrCount = 1 Then Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
If ErrCount = 2 Then Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")
If ErrCount = 3 Then Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
If ErrCount = 4 Then Set XMLHTTP = CreateObject("MSXML2.SERVERXMLHTTP")
If ErrCount = 5 Then Set XMLHTTP = CreateObject("MSXML2.SERVERXMLHTTP.3.0")
If ErrCount = 6 Then Set XMLHTTP = CreateObject("MSXML2.SERVERXMLHTTP.6.0")
If ErrCount = 7 Then Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
If ErrCount = 8 Then Set XMLHTTP = CreateObject("Microsoft.XMLHTTP.1.0")
If ErrCount = 9 Then Exit Do

Loop


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
Click to expand...
 
wrong place.

go use stackexchange
 
Not certain about that, but you initiated errorcount with a starting value of 1 but then on an error it adds one before getting to the "If ErrCount = 1 Then Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")" so that by the time it gets here the errorcount is 2 and the CreateObject("MSXML2.XMLHTTP") is never called.
 
Grayman said:
Not certain about that, but you initiated errorcount with a starting value of 1 but then on an error it adds one before getting to the "If ErrCount = 1 Then Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")" so that by the time it gets here the errorcount is 2 and the CreateObject("MSXML2.XMLHTTP") is never called.
Click to expand...

That was because MSXML2.XMLHTTP is already called in the regular code. I thought of a different way of doing this that avoided using the error handle by creating a RunCounter that counted after every run through the loop, and set if Then statements on each HTML object to trigger on multiples of 1 + 5x, but I'm still trying to figure how to code that properly. Back to reading :/
 
Last edited:
Last edited:
If anyone is interested in helping out, here's my newest attempt at the code. I added the If/End If statements and the XMLRun ="X" to try to track what object is being used.

Sub GoogleSearchExcelResults()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object
Dim start_time As Date
Dim end_time As Date
Dim cookie As String
Dim result_cookie As String
Dim Selec1 As Object
Dim Selec2 As Object
Dim Selec3 As Object
Dim rowNo As Integer
Dim test As Boolean



rowNo = 2

'Added This
Dim RunCount As Integer
RunCount = 1


Set Selec1 = Cells(rowNo, 7)

Set Selec2 = Cells(rowNo, 4)

Set Selec3 = Cells(rowNo, 20)



lastRow = Range("A" & Rows.Count).End(xlUp).Row


start_time = Time
Debug.Print "start_time:" & start_time



Do Until Selec1.Value = ""

'ErrResu:

Set Selec1 = Cells(rowNo, 7)

Set Selec2 = Cells(rowNo, 4)

url = "https://www.google.co.in/search?q=" & Selec1 & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)


Dim X As Integer
Dim Y As Integer
Dim Selec4 As Object
Set Selec4 = Cells(rowNo, 10)
'Dim Z As String
Y = X * 5
X = 0 And 1 And 2 And 3 And 4 And 5 And 6 And 7 And 8 And 9 And 10

If RunCount = 1 + Y Then
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLRun = "A"
End If
If RunCount = 2 + Y Then
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")
XMLRun = "B"
End If
If RunCount = 3 + Y Then
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.4.0")
XMLRun = "C"
End If
If RunCount = 4 + Y Then
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.5.0")
XMLRun = "D"
End If
If RunCount = 5 + Y Then
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
XMLRun = "E"
End If

Selec4 = XMLRun

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"


'Added This
On Error GoTo ErrResp

XMLHTTP.Send

'Exit Sub
'ErrResp:
'RunCount = RunCount + 1
'Resume ErrResu

Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.ResponseText



If html.getElementById("resultStats") Is Nothing Then
str_text = "Null Results"
Else
str_text = html.getElementById("resultStats").innerText
End If

If html.getElementById("topstuff") Is Nothing Then
str_text2 = "null"
Else
str_text2 = html.getElementById("topstuff").innerText
End If

Selec3 = str_text2

If InStr(Selec3.Value, "No results found for") = 0 Then
test = False
Else
test = True
End If

If test = True Then
str_text = "0 Results"
End If

Selec3.ClearContents


Selec2 = str_text

rowNo = rowNo + 1

Application.Wait (Now + TimeValue("0:00:05"))



'Added This
ErrResp:
RunCount = RunCount + 1
Resume Next

Loop



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
Click to expand...

If anyone has some tips, I could really use some. If no one wants/has time to help with this, then I'll stop posting here after this comment.
Thanks
 
You must log in or register to reply here.
Top Bottom
Back