Google Maps - Strasse aus Name, PLZ und Ort ausgeben...

Gegeben: Name, PLZ und Stadt der Firma. In Zelle daneben: Straße schreiben.
Bitte beachten: Es gibt Einschränkungen bei der Anzahl der Abfragen in Google Maps. Informieren Sie sich bitte über ALLE Einschränkungen.

Given: name, zip code and city of the company. In cell next to it: write street. Please note: There are restrictions on the number of queries in Google Maps. Please inform yourself about ALL restrictions.

Hier noch eine Beispieldatei / Here's a sample file:
Google Maps - Strasse aus Name, PLZ und Ort ausgeben...[XLSB 25 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : modAddress
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.04.2017
' Purpose   : Google Maps - Strasse aus Name, PLZ und Ort ausgeben...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim wksSheet As Worksheet
    Dim objXMLHTTP As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim objXML As Object
    Dim strURL As String
    Dim strPLZ As String
    Dim strOrt As String
    Dim lngCalc As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Tabellenblattname - bei Bedarf anpassen
    Set wksSheet = ThisWorkbook.Worksheets("Address")
    ' XMLHttpRequest Objekt = Transport von Daten über das Webprotokoll HTTP
    Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt (bzw. die Variable) wksSheet
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With wksSheet
        ' Von der ersten Zeile bis zur letzten in Spalte A
        For lngRow = 1 To IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
            ' Firmenname - Umlaute umwandeln (ä in ae usw.)
            strFirma = fncUmHTM(.Cells(lngRow, 1).Text)
            ' Postleitzahl
            strPLZ = .Cells(lngRow, 2).Text
            ' Ort/Stadt - Umlaute umwandeln (ä in ae usw.)
            strOrt = fncUmHTM(.Cells(lngRow, 3).Text)
            ' Internetadresse zusammensetzen
            strURL = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & _
                strFirma & "%20" & strPLZ & "%20" & strOrt & "&sensor=false"
            ' Wie gehabt With siehe oben...
            With objXMLHTTP
                ' HTTP Kommando, URL angeben, False = Daten Synchron laden
                .Open "GET", strURL, False
                ' Anfrage absenden
                .Send
            End With
            ' Status 200 - alles OK
            If objXMLHTTP.Status = 200 Then
                ' Rückgabe XML
                Set objXML = CreateObject("MSXML2.DOMDocument")
                With objXML
                    ' Der komplette Rückgabetext
                    .LoadXML objXMLHTTP.ResponseText
                    ' Es wurde was gefunden
                    If .ParseError.ErrorCode = 0 Then
                        ' Text am Komma aufsplitten und Strasse ausgeben
                        ' Wenn Strasse nicht an erster Stelle MUSS angepasst werden
                        wksSheet.Cells(lngRow, 4).Value = _
                            Split(.SelectSingleNode("//formatted_address").Text, ",")
                    ' sonst Fehler in die Zelle schreiben
                    Else
                        wksSheet.Cells(lngRow, 4).Value = "Kein Ergebnis!"
                    End If
                End With
            Else
                wksSheet.Cells(lngRow, 4).Value = "Fehler"
            End If
        Set objXML = Nothing
        Next lngRow
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set wksSheet = Nothing
    Set objXML = Nothing
    Set objXMLHTTP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
' Umlaute umwandeln
Private Function fncUmHTM(strTMP As String) As String
    Dim varS As Variant
    Dim varE As Variant
    Dim lngTMP As Long
    varS = Array("Ä", "Ö", "Ü", "ä", "ö", "ü", "ß")
    varE = Array("Ae", "Oe", "Ue", "ae", "oe", "ue", "ss")
    For lngTMP = 0 To UBound(varS)
        strTMP = Replace(strTMP, varS(lngTMP), varE(lngTMP))
    Next lngTMP
    fncUmHTM = strTMP
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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