Ako vytvoriť geografický nástroj na získanie súradníc zemepisnej šírky a dĺžky pre adresy pomocou programu Excel VBA

Postupujte podľa tohto článku a vytvorte si vlastný geografický nástroj, pomocou ktorého môžete získať súradnice zemepisnej šírky a dĺžky pre adresu. Takéto prevodníky bežne používajú realitní makléri.

stiahnuť

Ak chcete začať používať softvér čo najskôr, môžete:

Stiahnite si softvér teraz

V opačnom prípade si môžete prečítať obsah uvedený nižšie.

Poďme pripraviť GUI

Všetko, čo potrebujete, je jeden excelovský hárok a môžete ho pomenovať podľa svojich potrieb. V tomto príklade používam predvolený názov hárka „Hárok1“. Ďalším krokom je pridať potrebné hlavičky do tohto hárka. Prevodník zemepisnej šírky a dĺžky poskytne presný výsledok pre adresu, ktorú zadáme, ak vstup obsahuje predmestie, štát, PSČ a krajinu. Ako je znázornené na obrázku, pripravte si hlavičky. Pridajme zemepisnú šírku a dĺžku ako posledné dva stĺpce. Potrebujeme tiež tlačidlo, ktoré umožní používateľovi vykonať konverziu. Vložme teda tvar a vyplňme ho farbou, aby sa zobrazil ako tlačidlo.

Nech je to funkčné

Tu uvedený skript by sa mal skopírovať do nového modulu. Nezabudnite si zošit uložiť ako súbor zošita s povolenými makrami. Sub „FindThis“ by malo byť pripojené k tlačidlu, ktoré sme práve vytvorili.

Poďme to vyskúšať

Pridajte adresu spolu s ďalšími informáciami do príslušných stĺpcov. Kliknutím na tlačidlo spustíte makro, ktoré zobrazí zemepisné a dĺžkové súradnice pre všetky adresy uvedené na hárku. Makro sa spustí na riadku 2 a bude pokračovať, kým sa nedosiahne prázdny riadok.

Ako to funguje?

Pomocou skriptu sme vytvorili dve funkcie. Jeden na načítanie Lat hodnoty a druhý na načítanie Long hodnoty. Pomocou slučky FOR odovzdávame každú adresu týmto funkciám a zobrazujeme výsledok na obrazovke.

Skript

Function GETLAT(v_address As String, v_suburb As String, v_state As String, v_postcode As Long)
    
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    
    URl = "https://maps.googleapis.com/maps/api/geocode/xml?address=" & Application.WorksheetFunction.Substitute(v_address, " ", "+") & Application.WorksheetFunction.Substitute(v_suburb, " ", "+") & Application.WorksheetFunction.Substitute(v_state, " ", "+") & Application.WorksheetFunction.Substitute(v_postcode, " ", "+") & ",Australia"
    
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    xmlHttp.Open "GET", URl, False
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.send
    
    Set html = CreateObject("htmlfile")
    html.body.innerhtml = xmlHttp.ResponseText
    v_string = html.body.innerhtml
    x = InStr(1, v_string, "<LAT>")
    If x <> 0 Then
        y = InStr(x + 5, v_string, "</LAT>")
        GETLAT = Mid(v_string, x + 5, y - (x + 5))
    End If
End Function

Function GETLNG(v_address As String, v_suburb As String, v_state As String, v_postcode As Long)
    
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    
    URl = "https://maps.googleapis.com/maps/api/geocode/xml?address=" & Application.WorksheetFunction.Substitute(v_address, " ", "+") & Application.WorksheetFunction.Substitute(v_suburb, " ", "+") & Application.WorksheetFunction.Substitute(v_state, " ", "+") & Application.WorksheetFunction.Substitute(v_postcode, " ", "+") & ",Australia"
    
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    xmlHttp.Open "GET", URl, False
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.send
    
    Set html = CreateObject("htmlfile")
    html.body.innerhtml = xmlHttp.ResponseText
    v_string = html.body.innerhtml
    
    x = InStr(1, v_string, "<LNG>")
    If x <> 0 Then
        y = InStr(x + 5, v_string, "</LNG>")
        GETLNG = Mid(v_string, x + 5, y - (x + 5))
    End If
End Function

Sub FindThis()
    For r = 2 To 5
        Range("F" & r).Value = GETLAT(Range("A" & r).Value, Range("B" & r).Value, Range("C" & r).Value, Range("D" & r).Value)
        Range("G" & r).Value = GETLNG(Range("A" & r).Value, Range("B" & r).Value, Range("C" & r).Value, Range("D" & r).Value)
    Next r
End Sub

Ak pomocou skriptu nedostávate správne výsledky, pravdepodobným dôvodom môže byť poškodený program Excel. Potom môžete použiť Nástroj na obnovu súborov programu Excel ako DataNumen Excel Repair opraviť Excel.

Úvod autora:

Nick Vipond je expert na obnovu dát v DataNumen, Inc., ktorá je svetovým lídrom v oblasti technológií obnovy dát, vrátane opraviť dok problém a výhľadové softvérové ​​produkty na obnovenie. Pre viac informácií navštívte www.datanumen. S