Alle Länderlinks holen
17.06.2016 14:43:42
Zwenn
Hallo Oliver,
hier hast Du ein Makro, dass Dir die Links zu allen Ländern aus der von Dir verlinkten Seite generiert. Sie stehen nicht direkt im HTML-Code, lassen sich aber sehr leicht zusammenbauen, wenn man die Ländernamen kennt. Die kann man sehr einfach auslesen.
Das Makro erstellt Links zu den deutschsprachigen Seiten. Wenn Du das nicht willst, lösche einfach das Länderkürzel "de." in diesen beiden Zeilen:
strAusleseURL = "http://de.geopostcodes.com/data"
strGrundURL = "http://de.geopostcodes.com/"
Links zu den Ländergruppen (z.B. Nordamerika, Ozeanien, usw.) generiert das Makro nicht. Kann man aber entsprechend erweitern.
Option Explicit
Sub LinksEinlesen()
Dim strAusleseURL As String
Dim strGrundURL As String
Dim oIE As Object
Dim oKnoten As Object
Dim oKnotenSchleife As Object
Dim lZeile As Long
Dim strLinkTabelle As String
strAusleseURL = "http://de.geopostcodes.com/data"
strGrundURL = "http://de.geopostcodes.com/"
strLinkTabelle = ActiveSheet.Name
lZeile = 2
'Pauschal die ersten beiden Spalten der aktuellen Tabelle löschen
'Achtung: Dient nur zu Demonstrationszwecken, falls das Makro öfter gestartet wird
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'Kopfzeile
Sheets(strLinkTabelle).Cells(1, 1).Value = "Ländername deutsch"
Sheets(strLinkTabelle).Cells(1, 2).Value = "Länder-Link"
'Link im IE öffnen
Set oIE = CreateObject("internetexplorer.application")
oIE.Visible = False
oIE.Navigate strAusleseURL
Do Until oIE.ReadyState = 4: DoEvents: Loop
'Länderliste aus DOM Baum in eigenes Objekt übernehmen
Set oKnoten = oIE.document.getElementByID("countrieslist")
'Jeden a-Tag in der Länderliste durchgehen
For Each oKnotenSchleife In oKnoten.getElementsByTagName("a")
'Prüfen ob das Attribut "itemprop" im aktuellen a-Tag vorhanden ist
If oKnotenSchleife.getAttribute("itemprop") "" Then
'Wenn ja, deutschen Ländernamen in Spalte 1 der LinkTabelle schreiben
'href-Namen mit Grundlink verbinden und in Spalte 2 der LinkTabelle schreiben
Sheets(strLinkTabelle).Cells(lZeile, 1).Value = oKnotenSchleife.innertext
Sheets(strLinkTabelle).Cells(lZeile, 2).Value = strGrundURL & _
oKnotenSchleife.getAttribute("href")
lZeile = lZeile + 1
End If
Next oKnotenSchleife
'Spaltenbreite automatisch anpassen
Columns("A:B").EntireColumn.AutoFit
If ActiveWindow.FreezePanes = False Then
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
End If
oIE.Quit
Set oKnoten = Nothing
Set oKnotenSchleife = Nothing
Set oIE = Nothing
End Sub
Viele Grüße,
Zwenn