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
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