错误:未设置对象变量或块变量(VBA)

时间:2018-07-22 02:46:14

标签: javascript html excel vba web

我尝试创建一个宏,该宏从网页中提取某些标签的所有单词。分别计算,计数,然后使用Google API查找它给出了多少结果,例如,您好网站:www.hello.com,随后宏应说出具有更多结果的10个单词。尚未结束的事情。

一切正常,就是只有一个变量使我失败。

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

出现以下消息

enter image description here

如果您发现可以改进的地方,那就太好了

 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

0 个答案:

没有答案