Strassenname mit Google Maps!

Wichtig / Important: Neue Version - Google Maps - Strassenname ermitteln...
In einer Tabelle stehen in A1 (folgende) der Firmenname in B1 (folgende) die PLZ und in C1 (folgende) der Ort. Der Strassenname soll ermittelt werden. Hier eine Lösung mit Google Maps. Getestet mit Excel 2003/2010 und Internetexplorer 8.

Google Maps - Strassenname ermitteln... [ZIP, 60 KB]

Option Explicit
Private Enum IE_READYSTATE
    Uninitialised = 0
    Loading = 1
    Loaded = 2
    Interactive = 3
    Complete = 4
End Enum
Sub Test()
    Dim wksSheet As Worksheet
    Dim objResult As Object
    Dim objIEApp As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim strPLZ As String
    Dim strOrt As String
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        strFirma = .Cells(1, 1).Value
        strPLZ = .Cells(1, 2).Value
        strOrt = .Cells(1, 3).Value
    End With
    Set objIEApp = CreateObject("InternetExplorer.Application")
    With objIEApp
        .Visible = False ' True = sichtbar
        .Navigate2 "http://maps.google.com/maps?q=" & _
            strFirma & " " & strPLZ & " " & strOrt
        Do Until objIEApp.readyState = _
            IE_READYSTATE.Complete: DoEvents: Loop
        Set objResult = .Document.getElementById("adr")
        If Not objResult Is Nothing Then
            varArr = Split(objResult.innerText, ",")
            wksSheet.Cells(1, 4).Value = varArr(0)
        Else
            wksSheet.Cells(1, 4).Value = "Kein Ergebnis!"
        End If
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEApp = Nothing
    Set wksSheet = Nothing
End Sub

'Code: Alle Adressen

Option Explicit
Private Enum IE_READYSTATE
    Uninitialised = 0
    Loading = 1
    Loaded = 2
    Interactive = 3
    Complete = 4
End Enum
Sub Test_1()
    Dim wksSheet As Worksheet
    Dim objResult As Object
    Dim objIEApp As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim strPLZ As String
    Dim strOrt As String
    Dim lngRow As Long
    On Error GoTo Fin
    Set objIEApp = CreateObject("InternetExplorer.Application")
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    With objIEApp
        .Visible = False ' True = sichtbar
        For lngRow = 1 To lngRow
            With wksSheet
                strFirma = .Cells(lngRow, 1).Value
                strPLZ = .Cells(lngRow, 2).Value
                strOrt = .Cells(lngRow, 3).Value
            End With
            .Navigate2 "http://maps.google.com/maps?q=" & _
                strFirma & " " & strPLZ & " " & strOrt
            Do Until objIEApp.readyState = _
                IE_READYSTATE.Complete: DoEvents: Loop
            Set objResult = .Document.getElementById("adr")
            With wksSheet
                If Not objResult Is Nothing Then
                    varArr = Split(objResult.innerText, ",")
                    .Cells(lngRow, 4).Value = varArr(0)
                Else
                    .Visible = True
                    .Cells(lngRow, 4).Value = "Kein Ergebnis!"
                End If
            End With
        Next lngRow
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEApp = Nothing
    Set wksSheet = Nothing
End Sub
Problem! Goggle kann jederzeit - und das wird auch in unregelmässigen Abständen gemacht - Teile der Homepage ändern. Dies beinhaltet z. B. auch den Punkt "getElementById". Dann kracht der Code natürlich. Wenn man das Problem umgehen möchte sollte man sich zwangsläufig mit der Google API auseinandersetzen. Näher Informationen dazu liefert eine Suchmaschine ihrer Wahl. :-)
Nachfolgend mal einen Code, der das erste Ergebnis in einer MsgBox anzeigt. Das muss natürlich dann noch über z. B. "Split" aufgeteilt werden:
Option Explicit
Sub Main()
    Dim objIEDocument As Object
    Dim objResult As Object
    Dim objIEApp As Object
    Dim wksSheet As Worksheet
    Dim strFirma As String
    Dim strPLZ As String
    Dim strOrt As String
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' anpassen!!!
    With wksSheet
        strFirma = .Cells(1, 1).Value
        strPLZ = .Cells(1, 2).Value
        strOrt = .Cells(1, 3).Value
    End With
    Set objIEApp = CreateObject("InternetExplorer.Application")
    With objIEApp
        .Visible = False ' True
        .Navigate2 "http://maps.google.com/maps?q=" & _
            strFirma & " " & strPLZ & " " & strOrt
        Do: Loop Until .Busy = False
        Do: Loop Until .Busy = False
        Set objIEDocument = .Document
        With .Document
            Do: Loop Until .ReadyState = "complete"
            Set objResult = .getElementById("panel_A_2")
            If Not objResult Is Nothing Then
                MsgBox objResult.InnerText
            End If
        End With
    End With
Fin:
    If Not objIEApp Is Nothing Then objIEApp.Quit
    Set objIEDocument = Nothing
    Set objIEApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
"getElementById("panel_A_2")" kann natürlich in Kürze wieder anders heissen. :-)

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...