AW: URL´s aus HTML Quellcode auslesen
31.01.2020 18:04:36
volti
Hallo Philip,
hier doch noch mal eine neue Version, die die Ermittlung der relevanten Firmen jetzt anders, deutlich schneller ermittelt, weil nur noch Text und nicht der ganze andere Kram mitgeladen wird.
Hier wird jedoch nur die Such-Seite vernüftig unterstützt, welche merkwürdigerweise doppelt so viele Firmen ausgibt.
Bei IT-Outsourcing 1.336 statt bisher 652 Firmen. Ich verstehe diese Web-Anwendung irgendwie nicht, naja.
Für die Einzelermittlung wird leider fast eine Sekunde pro Firma zum Extrahieren der Daten benötigt, bei mehr als 6.000 Zerspahnungs-Firmen kommt da schon was zeitmäßig zusammen..
PS: Bei 6.000 Firmen habe ich jetzt abgebrochen..
Entscheide selbst, ob, was und wie Du das jetzt nutzen möchtest. Ich verabschiede mich jetzt von dem sicherlich spannenden Thema.
https://www.herber.de/bbs/user/134882.xlsb
Datei hatte 960 KB, musste ich wieder kürzen.
Option Explicit
Option COMPARE TEXT
Sub Firmen_Aus_Web_Auflisten()
Dim oIE As Object
Dim sTeil() As String, sArr() As String, sUrl As String
Dim i As Long, j As Long, iSite As Long
Set oIE = CreateObject("InternetExplorer.application")
With CreateObject("MSXML2.XMLHTTP")
For iSite = 1 To 250 'Anzahl der Seiten je 30 Firmen
' sUrl = "https://www.wlw.de/de/suche/it-outsourcing/page/" & iSite
sUrl = "https://www.wlw.de/de/suche/cnc-zerspanung/page/" & iSite
.Open "GET", sUrl, False
.Send
sTeil = Split(.responsetext, "data-v-7f25727b><a href=" & Chr$(34))
For i = 1 To UBound(sTeil)
ReDim Preserve sArr(5, j)
sArr(0, j) = "https://www.wlw.de" & Left$(sTeil(i), InStr(sTeil(i), Chr$(34)) - 1)
oIE.Navigate sArr(0, j) 'Zur Url surfen
While Not oIE.ReadyState = 4: DoEvents: Wend 'Warten bis Seite geladen ist
With oIE.document
On Error Resume Next
sArr(1, j) = Trim$(.getElementById( _
"location-and-contact__website").outertext)
DoEvents
sArr(2, j) = Trim$(.getelementsbytagname("H1")(0).outertext)
Application.StatusBar = "Seite " & iSite & ", " _
& (j + 1) & ". Firma " & sArr(2, j)
sArr(3, j) = Trim$(.getElementById( _
"business-card__address").outertext)
sArr(4, j) = Trim$(Mid$(.getElementById( _
"links__email").outertext, 15))
sArr(5, j) = Trim$(Mid$(.getElementById( _
"buttons__phone").outertext, 31))
End With
j = j + 1
Next i
If i < 31 Then Exit For
Next iSite
End With
'Daten ausgeben
With ThisWorkbook.Sheets("Tabelle1") 'Ausgabeblatt ggf. anpassen
.Select
.Cells.ClearContents
.Range("$A$1").Resize(1, 6).Value = Split( _
"Link,Web-Site,Firma,Adresse,Kontakt,Telefon", ",") 'überschriften ggf. anpassen
.Cells(2, 1).Resize(j, 6).Value = Application.Transpose(sArr())
End With
oIE.Quit
Set oIE = Nothing
MsgBox "Bin fertig ", vbInformation, "Web-Daten abholen"
End Sub
viele Grüße
Karl-Heinz