Non ditemi per favore che sono Noioso,
Nel Voler Proprorre sempre le stesse cose ; ma credetemi stò cercando di fare di tutto per voler imparare veramente; ma quando riesco a risolvere un problema mi se ne ri_presenta un altro ha qui non riesco a trovare una soluzione logica.
Il Problema e questo : Il Vorrei ricavare in base a determinati criteri posizionati sul foglio di Excel con Microsoft office 2007
Tutto ciò che si potrebbe ricavare dal sito "Immobiliare.it"
Pertanto : Grazie al vetro aiuti precedenti ho voluto buttare giù un programma tutto mio : E questo e il suo Listato .
- Codice: Seleziona tutto
Option Explicit
Sub GetSocial()
Dim HTML As New HTMLDocument
Dim http As Object
Dim row As Long
Dim continue As Boolean
Dim listings As IHTMLElementCollection
Dim listing As IHTMLElementCollection
Dim ul As HTMLUListElement
Dim li As HTMLLIElement
Dim I As Long
Dim page As Long
Dim URL As String
Dim Start As Range
Dim X As String
Dim Y As String
Dim T As String
Dim P As Variant
Dim P2 As Variant
Dim MQ As Variant
Dim MQ2 As Variant
Application.ScreenUpdating = False
row = 0
page = 1
continue = True
Set Start = Range("D6")
X = Sheets("Trova_E_Visualizza").Range("A5").Value
Y = Sheets("Trova_E_Visualizza").Range("B5").Value
T = Sheets("Trova_E_Visualizza").Range("C5").Value
P = Sheets("Trova_E_Visualizza").Range("D5").Value
P2 = Sheets("Trova_E_Visualizza").Range("D6").Value
MQ = Sheets("Trova_E_Visualizza").Range("E5").Value
MQ2 = Sheets("Trova_E_Visualizza").Range("E6").Value
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
While continue
URL = "https://www.immobiliare.it/" & X & "" & T & "/" & Y
'?pag=/" & page &
With http
'On Error Resume Next
.Open "GET", URL, False
.send
' If Err.Num is not 0 then an error occurred accessing the website
' This checks for badly formatted URL's. The website can still return an error
' which should be checked in .Status
' If the website sent a valid response to our request
If Err.Number = 0 Then
If .Status = 200 Then
HTML.body.innerHTML = http.responseText
Set listings = HTML.getElementsByClassName("listing-features list-piped")
'Prrova Oggetti; Da; Provare; Per; Estrappolare; Dati
'listing-features list-piped
'clearfix left-side-listing
For Each ul In listings
I = 1
For Each li In ul.getElementsByTagName("li")
'li In ul.getElementsByTagName("li")
If I = 1 Then
Start.Offset(row, 0).Value = li.innerText
End If
If InStr(li.innerText, "m1") Then
Start.Offset(row, 1).Value = Left(ul.innerText, InStrRev(li.innerText, "ul") + 1)
End If
I = I + 1
Next
row = row + 1
Next
Else
continue = False
End If
Else
continue = False
On Error GoTo 0
End If
On Error GoTo 0
End With
page = page + 1
Wend
Application.ScreenUpdating = True
End Sub
Haora devo dire che come programma non va male.
Il problemi sono in sostanza due che sono :
1) che quando avvio la procedura di ricerca ; La ricerca non smette mai a patto che io non prema immediatamente da tastiera il tasto (Esc)
2) Una volta fatto ciò , chiaramente il programma mi da errore , ma ironia della sorte mi scarica i soli dati inerente hai prezzi delle care della mia ricerca e non le voci appartenenti all'oggetto stesso
Provare per capire meglio il tutto Grazie
(P.S) Questo e il lino per scaricare il mio file di prova :
https://app.box.com/s/jvmqzrjb32jezyn6romplqfs6mtq9p2k
E Per finire : Secondo voi non ci sarebbe la possibilità di avere dei link , dove io possa attingere tali metodi
Ma che a sua volta mi possano Aiutare a farli incanalare con il linguaggio VBA GRazie
Sinceri Saluti da A.Maurizio
