Option Explicit
Sub Suche()
Dim InternetExplorer As Object
Dim Zeile As Integer
Dim objElement As Object
Dim objCollection As Object
Dim link As String
Dim strplz As String
Dim strname As String
Dim i As Integer
Dim l As Object
Dim found As Boolean
Set InternetExplorer = CreateObject("InternetExplorer.Application")
InternetExplorer.Visible = True
Application.StatusBar = "Das Örtliche wird geladen bitte warten..."
Zeile = 1
neu:
Zeile = Zeile + 1
Do While Not IsEmpty(WorkbookQuelle.Sheets("Sheet1").Cells(Zeile, 1))
strname = WorkbookQuelle.Sheets("Sheet1").Cells(Zeile, name).Value
strplz = WorkbookQuelle.Sheets("Sheet1").Cells(Zeile, plz).Value
strname = Replace(strname, " ", "+")
InternetExplorer.navigate link
Do While InternetExplorer.readystate <> 4
Application.Wait (Now + TimeValue("00:00:01"))
Loop
Debug.Print Zeile
found = False
i = 0
Set objCollection = InternetExplorer.document.getelementsbytagname("a")
Do While i < objCollection.Length
If (objCollection(i).classname = "name ") Then
Set objElement = objCollection(i)
found = True
Exit Do
End If
i = i + 1
Loop
If (i = 0) Then
MsgBox "Falscher Index i"
Exit Sub
End If
If (found <> True) Then
WorkbookQuelle.Sheets("Sheet1").Cells(Zeile, 1).Interior.ColorIndex = 3
GoTo neu
End If
objElement.Click
Zeile = Zeile + 1
Loop
Application.StatusBar = "Fertig"
Set objElement = Nothing
Set objCollection = Nothing
InternetExplorer.Quit
Set InternetExplorer = Nothing
End Sub