Hallo T.
Ich habe da mal was gebastelt ;-) Bitte die Kommentare im Makro aufmerksam lesen. Ich habe Dir schon die Schleife vorbereitet, um mehrere Suchbegriffe abzuarbeiten. Da musst Du aber noch etwas nacharbeiten. Für den Vergleich auf doppelte Jobangebote (ja, ist notwendig) habe ich mirr ein paar mehr graue Haare eingehandelt. Wer ahnt denn, dass StepStone irgendwelche individuellen blöden IDs in die URL schreibt, die man nicht braucht? ;-)
Ok, Rockn Roll. Was Du sonst noch brauchst, wirst Du hinbekommen denke ich^^
Das eigentliche Makro:
Sub StepStoneJobsAuslesen()
'*************************************************************
'Das Makro schreibt ab der ersten freien Zeile in die Tabelle,
'aus der es gestartet wird. Die Kopfzeile wird ignoriert
'*************************************************************
'Es sind 3 Parameter notwendig:
'Die Reihenfolge von URL-Parametern ist egal
'Deshalb nimmt man die Konstanten nach vorne
'Der erste URL-Parameter/ die Parameterliste wird mit dem Fragezeichen eingeleitet (?)
'Jeder weitere Parameter wird mit dem Kaufmanns-Und abgetrennt (&)
'li=100 [Setzt die Anzahl der Suchtreffer pro Seite auf 100. Mehr geht nicht]
'ex=90002 [Filtert die Suchergebnisse auf "Mit Berufserfahrung]
'ke= [Hinter dem Parameternamen ke kommt der Suchterm. Der ist dynamisch]
Const baseUrl As String = "https://www.stepstone.de/5/ergebnisliste.html?li=100&ex=90002&ke="
Dim browser As Object
Dim url As String
Dim urlSearchTerm As String
Dim urlSearchTermClear As String
Dim nodeJobOfferContainer As Object
Dim nodeAllJobOffers As Object
Dim nodeOneJobOffer As Object
Dim nodeNextButton As Object
Dim currentRow As Long
Dim jobOfferTitle As String
Dim jobOfferUrl As String
Dim nextPagePossible As Boolean
Dim jobOfferUrlDict As Object
Dim cellUrl As String
Dim fillDictRow As Long
Dim questionMarkIndex As Long
Dim urlLengthLeft As Long
'Erste freie Zeile anhand von Spalte A in der aktiven Tabelle feststellen
currentRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Scripting-Dictionary einrichten für schnelle Prüfung auf doppelte Jobangebote
'Diese lassen sich am Link erkennen und im Dectionary leicht über Exists() prüfen
Set jobOfferUrlDict = CreateObject("Scripting.Dictionary")
'Case Sensitive für Exists() abschalten
jobOfferUrlDict.CompareMode = vbTextCompare
'In der Tabelle vorhandene Links ins Dictionary aufnehmen
'So werden später durchgeführte Makroläufe mit gleichen
'Suchbegriffen möglich. Diese schreiben dann nur neue
'Jobangebote in die Tabelle
'
'Achtung:
'Werden die Spaltenzuordnungen verändert, muss das hier
'angepasst werden. Das Makro geht von URLs in Spalte B aus
For fillDictRow = 2 To currentRow - 1
'Falls es Suchtbegriffe ohne Treffer gab, gibt es evtl.
'Zeilen ohne URL. Die müssen übersprungen werden
If ActiveSheet.Cells(fillDictRow, 2).Hyperlinks.Count = 1 Then
'Hyperlink in Dictionary aufnehmen und überflüssiges Value setzen
'Wir brauchen das Dictionary zum schnellen Abgleich doppelter URLs
'über die Exists() Methode. Die URLs werden dafür als Keys gesetzt
cellUrl = ActiveSheet.Cells(fillDictRow, 2).Hyperlinks(1).Address
jobOfferUrlDict(cellUrl) = cellUrl
End If
Next fillDictRow
'Dynamisierung für mehrere Suchbegriffe gehört ab hier in eine Schleife
'Die lasse ich jetzt weg, weil die nur im Zusammenhang mit mehreren
'abzuarbeitenden Suchbegriffen in einer Tabelle Sinn macht
'Deshalb wird hier mit folgenden statischen Suchbegriff zum Testen gearbeitet
'
'Variablendeklarationen und Initialisierung für die Schleife fehlen noch
'For currentRowSearchTerms = startRow to endRow
'Test-Suchbegriffe
'urlSearchTerm = "abb ag" 'Weniger als 100 Suchtreffer = 1 Seite
urlSearchTerm = "Entwickler" 'Mehr als 100 Suchtreffer = >1 Seite
'urlSearchTerm = "Mazars Advisors GmbH & Co. KG" 'Suchbegriff mit in URL verbotenem Sonderzeichen
'
'Bei Aktivierung der Suchterm-Schleife, alle Test-Suchbegriffe auskommentieren
'Nächster Suchbegriff bei Abarbeitung mehrerer aus einer Tabelle
'urlSearchTerm = Sheets("SuchTermTabelle-ANPASSEN").Cells(currentRowSearchTerms, 1).Value
'In URL verbotene Sonderzeichen werden automatisiert ersetzt
urlSearchTermClear = PrepareSearchTerm(urlSearchTerm)
'Es ergibt sich die ganze URL
url = baseUrl & urlSearchTermClear
'Internet Explorer initialisieren, Sichtbarkeit festlegen,
'URL aufrufen und warten bis Seite vollständig geladen wurde
Set browser = CreateObject("internetexplorer.application")
browser.Visible = True
browser.navigate url
Do Until browser.readyState = 4: DoEvents: Loop
'Schleife zum Durchgehen der Paginierung
'(Aller Seiten mit Suchergebnissen zum Suchbegriff)
'Paginierung ist der Fachbegriff, der auch oft im HTML Code zu finden ist)
'Eine Seite gibt es auf jeden Fall, deshalb eine Fußgesteuerte Schleife
Do
'Versuchen, den Container mit den Jobangeboten zu separieren
Set nodeJobOfferContainer = browser.document.getElementsByClassName("gvBCse")(0)
'Weiter, wenn es Suchtreffer gibt
If Not nodeJobOfferContainer Is Nothing Then
'Alle Jobangebote in eine NodeList schreiben
Set nodeAllJobOffers = nodeJobOfferContainer.getElementsByClassName("fKQtCB")
'Alle Jobangebote durchgehen und in die aktive Tabelle schreiben
For Each nodeOneJobOffer In nodeAllJobOffers
'URL des Jobangebots auslesen
jobOfferUrl = nodeOneJobOffer.getElementsByClassName("gzNLsV")(0).href
'Die Parameterliste der URL entfernen. Denn der Parameter "suid" hat immer
'einen anderen Wert. Deshalb gibt es nie gleiche URLs mit dem Parameter
'"suid", die sich für unsere Zwecke als solche erkennen lassen. Es gibt
'den weiteren Parameter rltr, der aber auch einfach weggelassen werden kann
'Das Jobangebot lässt sich trotzdem durch anklicken des Links in der Tabelle
'aufrufen
'
'Index des Fragezeichens finden (leitet die Parameterliste ein)
questionMarkIndex = InStr(1, jobOfferUrl, "?")
'Sicher gehen, dass es eine Parameterliste gibt
If questionMarkIndex > 0 Then
'Länge der zu löschenden Parameterliste
urlLengthLeft = Len(jobOfferUrl) - ((Len(jobOfferUrl) - questionMarkIndex) + 1)
'Zu löschende Parameterliste
jobOfferUrl = Left(jobOfferUrl, urlLengthLeft)
End If
'Wenn es den Link noch nicht in der Tabelle gibt,
'ins Dictionary und die Tabelle eintragen
If Not jobOfferUrlDict.Exists(jobOfferUrl) Then
'Mitscrollen zur Sichtkontrolle ab Zeile 15
If currentRow > 14 Then
ActiveWindow.SmallScroll down:=1
End If
'Eintrag ins Dictionary und mit Value als gleichen Wert
'(Value ist hier überflüssig, muss aber gesetzt werden
' Wir wollen nur die Exists() Methode ausnutzen, die auf
' den Key prüft)
jobOfferUrlDict(jobOfferUrl) = jobOfferUrl
'Eintrag in die Tabelle
'
'Suchterm in Spalte A eintragen
'Bei mehreren Firmen ist die Zuordnung damit automatisch gegeben
ActiveSheet.Cells(currentRow, 1).Value = urlSearchTerm
'Titel des Jobangebots auslesen
jobOfferTitle = Trim(nodeOneJobOffer.getElementsByClassName("iHAUBO")(0).innertext)
'Titel als Link in die Tabelle schreiben
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(currentRow, 2), Address:=jobOfferUrl, TextToDisplay:=jobOfferTitle
'Datum und Uhrzeit eintragen (Spalten entsprechend Formatieren)
ActiveSheet.Cells(currentRow, 3).Value = Int(Now)
ActiveSheet.Cells(currentRow, 4).Value = Now() - Int(Now)
'Nächste Zeile vorbereiten
currentRow = currentRow + 1
End If
Next nodeOneJobOffer
'Prüfen, ob es eine weitere Seite mit Suchtreffern gibt
'Versuchen den Weiter-Button zu separieren
Set nodeNextButton = browser.document.getElementsByClassName("euFwQt")(0)
'Prüfen, ob er gefunden wurde
If Not nodeNextButton Is Nothing Then
'Anklicken
nodeNextButton.Click
'Manuelle Pause zum Seite laden
'Die drei hinteren Werte sind Stunden, Minuten, Sekunden
'(Evtl. anpassen. Ist aber reiner Zeitfaktor, da doppelte
' Treffer in der Tabelle, oben verhindert werden)
Application.Wait (Now + TimeSerial(0, 0, 3))
'Es gibt eine weitere Suchseite
nextPagePossible = True
Else
'Ende der Paginierung erreicht
nextPagePossible = False
End If
Else
'Suchterm, Keine-Treffer-Meldung und Zeitstempel in die Tabelle schreiben
'
'Suchterm in Spalte A eintragen
'Bei mehreren Firmen ist die Zuordnung damit automatisch gegeben
ActiveSheet.Cells(currentRow, 1).Value = urlSearchTerm
ActiveSheet.Cells(currentRow, 2).Value = "keine Suchergebnisse"
ActiveSheet.Cells(currentRow, 3).Value = Int(Now)
ActiveSheet.Cells(currentRow, 4).Value = Now() - Int(Now)
'Nächste Zeile vorbereiten
'(Wichtig sobald mehrere Suchbegriffe in einer Schleife abgearbeitet werden)
currentRow = currentRow + 1
'Es gibt keine Seite zum durchblättern
'(Wichtig sobald mehrere Suchbegriffe in einer Schleife abgearbeitet werden)
nextPagePossible = False
End If
Loop While nextPagePossible
'Aufräumen
browser.Quit
Set browser = Nothing
Set nodeJobOfferContainer = Nothing
Set nodeAllJobOffers = Nothing
Set nodeOneJobOffer = Nothing
'Hier endet die Schleife bei Abarbeitung mehrerer Suchbegriffe
'next currentRowSearchTerms
End Sub
Die Funktion zum Umwandeln unerlaubter Zeichen in einer URL, in URL-Codierung. Keine Ahnung ob die Zeichen vollständig sind. Kann man aber ggf. leicht erweitern. Kommt aus einem Amazon Projekt, habe ich einfach 1 zu 1 übernommen:
Function PrepareSearchTerm(rawSearchTerm As String) As String
Dim searchTerm As String
'Die Codierung der Zeichen muss in einer
'bestimmten Reihenfolge ablaufen. Sonst
'werden die Codes schon codierter Zeichen
'ggf. teilweise überschrieben
'Alle Zeichen, die in einer URL verboten
'sind durch URL-Codierung ersetzen
searchTerm = Replace(rawSearchTerm, "%", "%25")
searchTerm = Replace(searchTerm, "?", "%3F")
searchTerm = Replace(searchTerm, "&", "%26")
searchTerm = Replace(searchTerm, "#", "%23")
searchTerm = Replace(searchTerm, "/", "%2F")
searchTerm = Replace(searchTerm, "$", "%24")
searchTerm = Replace(searchTerm, "+", "%2B")
searchTerm = Replace(searchTerm, ":", "%3A")
searchTerm = Replace(searchTerm, ";", "%3B")
searchTerm = Replace(searchTerm, "=", "%3D")
searchTerm = Replace(searchTerm, "@", "%40")
'Das Komma wird von Amazon ungewöhnlich codiert
searchTerm = Replace(searchTerm, ",", "\c")
'Zum Schluss alle Leerzeichen durch ein Plus ersetzen
searchTerm = Replace(searchTerm, " ", "+")
PrepareSearchTerm = searchTerm
End Function
Viele Grüße,
Zwenn
|