samedi 21 juillet 2018

Error: Object variable or with block variable not set (VBA)

I try to create a macro that extracts all the words of certain tags from a web page. Separate, count and then with the Google API find how many results it gives, for example, hello site: www.hello.com, later the macro should say the 10 words that have more results. Something that has not ended yet.

Everything works perfectly, only one variable fails me, that is.

Cells (i, 5). Value = var1.innerText

The following message appears

enter image description here

If you find something that can be improved, it would be great

I also attach my excel.

 Sub GrabLastNames()

    screenUpdateStatus = Application.ScreenUpdating
    statusBarStatus = Application.DisplayStatusBar
    calcStatus = Application.Calculation
    eventsStatus = Application.EnableEvents
    displayPageBreakStatus = ActiveSheet.DisplayPageBreaks
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayAlerts = True

 Dim ultima As Long, url As String
 Sheets("Sheet1").Select
 ultima = Sheets("Sheet1").Range("A10000").End(xlUp).Row

 For j = 2 To ultima

Dim objIE As InternetExplorer
Dim ele As Object
Dim y As Integer
url = Sheets("Sheet1").Range("A" & j)

Set objIE = New InternetExplorer
objIE.Visible = False

objIE.navigate url
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop

y = 1

For Each ele In objIE.document.getElementsByTagName("p")
    Sheets("Sheet2").Range("A" & y).Value = ele.textContent
    y = y + 1

Next

For Each ele In objIE.document.getElementsByTagName("h1")
    Sheets("Sheet2").Range("A" & y).Value = ele.textContent
    y = y + 1

Next

For Each ele In objIE.document.getElementsByTagName("h2")
    Sheets("Sheet2").Range("A" & y).Value = ele.textContent
    y = y + 1

Next

For Each ele In objIE.document.getElementsByTagName("h3")
    Sheets("Sheet2").Range("A" & y).Value = ele.textContent
    y = y + 1

Next

    For Each ele In objIE.document.getElementsByTagName("a")
    Sheets("Sheet2").Range("A" & y).Value = ele.textContent
    y = y + 1

Next

   objIE.document.getElementsByTagName ("title")
   Sheets("Sheet2").Range("A" & y).Value = 
  objIE.document.getElementsByTagName("title")(0).innerHTML

    y = 0

 Call palabras

 Dim w As Long, jj As Integer

 jj = 1
 objIE.Quit

 Call GetHits(url)

 For w = 1 To Sheets("Sheet2").Range("C3").End(xlUp).Row

 If Len(Sheets("Sheet2").Range("C" & w)) > 6 Then
     If Sheets("Sheet2").Range("C" & w) = "hvordan" Or 
  Sheets("Sheet2").Range("C" & w) = "cookies" Or Sheets("Sheet2").Range("C" & 
  w) = 
  "Hvordan" _
     Or Sheets("Sheet2").Range("C" & w) = "hvorfra" Or      
  Sheets("Sheet2").Range("C" & w) = "Danmark" Or Sheets("Sheet2").Range("C" & 
  w) =                
 "Velkommen" Then
     Else
         Sheets("Sheet1").Cells(j, 1 + jj) = Sheets("Sheet2").Range("C" & w)
         jj = jj + 1
         If jj = 11 Then
            Exit For
         End If
     End If
End If

Next w

Dim ult As Long

ult = Sheets("Sheet2").Range("A10000").End(xlUp).Row
Sheets("Sheet1").Cells(j, 1 + jj) = Sheets("Sheet2").Range("A" & ult)
Sheets("Sheet2").Cells.Delete

Next j

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = True
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
 End Sub

 Sub palabras()
 Sheets("Sheet2").Select
 ultima = Sheets("Sheet2").Range("A10000").End(xlUp).Row

For i = 1 To ultima
 'Do While Sheets("Sheet2").Range("A" & i).Value <> ""
tope = Len(Sheets("Sheet2").Range("A" & i))
Final = ""
    For x = 1 To tope + 1

        extrae = Mid(Sheets("Sheet2").Range("A" & i), x, 1)
        If extrae = "" Then
            Final = Final & "," & lista
            lista = ""
        End If
        If extrae = " " Then
            Final = Final & "," & lista
            lista = ""
        End If
        lista = lista & extrae
    Next
    Sheets("Sheet2").Select
    Range("A" & i).Offset(1, 0).Select
    Final = Replace(Final, " ", "")
    Final = Mid(Final, 2, Len(Final) - 1)
    Final = Split(Final, ",")
    ultima22 = Sheets("Sheet2").Range("C10000").End(xlUp).Row
    p = 0
    For p = 0 To UBound(Final)
        Sheets("Sheet2").Range("C" & p + ultima22 + 1).Value = Final(p)
    Next

    Next i

    ultima222 = Sheets("Sheet2").Range("C10000").End(xlUp).Row
    For g = 1 To ultima222

    Sheets("Sheet2").Range("D" & g).Value = 
    Application.WorksheetFunction.CountIf(Columns("C"), 
    Sheets("Sheet2").Range("C" & g))

    Next g
    Sheets("Sheet2").Range("C1:D" & 
    Sheets("Sheet2").Range("c65000").End(xlUp).Row).Sort 
    key1:=Sheets("Sheet2").Range("D1"), order1:=xlDescending, Header:=xlNo, 
    ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveSheet.Range("C1:D10000").RemoveDuplicates Columns:=Array(1, 2), _
    Header:=xlNo
    End Sub

    Sub GetHits(ByVal url As String)

    screenUpdateStatus = Application.ScreenUpdating
    statusBarStatus = Application.DisplayStatusBar
    calcStatus = Application.Calculation
    eventsStatus = Application.EnableEvents
    displayPageBreakStatus = ActiveSheet.DisplayPageBreaks
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayAlerts = True

Dim url1 As String, lastRow As Long, XMLHTTP As Object, html As Object, 
objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date, end_time As Date, var As String, var1 As Object, dato  
As String

lastRow = Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Row

start_time = Time
url = Right(url, Len(url) - 4)
If Len(dato) = 3 Then
    Else
    For i = 1 To lastRow
    dato = Sheets("Sheet2").Cells(i, 3).Value
    url1 = "https://www.google.com/search?q=" & dato & " site : " & url & " & 
    Rnd = " & WorksheetFunction.RandBetween(1, 10000)

    Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
    XMLHTTP.Open "GET", url1, 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 var1 = html.getElementById("resultStats")
    'If var1.innerText = "" Then
    'Else
    Cells(i, 5).Value = var1.innerText
    Cells(i, 6).Value = "https://www.google.com/search?q=" & Cells(i, 1) & " 
 site : " & url & " & " & Rnd = " & WorksheetFunction.RandBetween(1, 10000)"
    'End If
   'DoEvents
Next
End If
end_time = Time

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = True
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState

End Sub




Aucun commentaire:

Enregistrer un commentaire