Kako stvoriti geografski alat za dobivanje koordinata zemljopisne širine i dužine za adrese pomoću programa Excel VBA

Excel rješenja 3. listopada 2025.

Slijedite ovaj članak i izradite vlastiti geografski alat pomoću kojeg možete dobiti koordinate zemljopisne širine i dužine za adresu. Ovakve pretvarače obično koriste posrednici u prometu nekretninama.

Preuzmite sada

Ako želite start koristiti softver što je prije moguće, tada možete:

Preuzmite softver sada

Inače, ako želite DIY, možete pročitati sadržaj u nastavku.

Pripremimo GUI

Sve što trebate je jedan Excel list i možete ga imenovati prema svojim potrebama. U ovom primjeru koristim zadani naziv lista "Sheet1". Sljedeći korak je dodavanje potrebnih zaglavlja na ovaj list. Pretvarač zemljopisne širine i dužine daje točan rezultat za adresu koju prosljeđujemo ako unos uključuje predgrađe, državu, postšifra i država. Kao što je prikazano na slici, pripremite zaglavlja. Dodajmo Latitude i Longitude kao zadnja dva stupca. Također nam je potreban gumb koji će korisniku omogućiti pretvorbu. Umetnimo oblik i ispunimo ga bojom kako bi izgledao kao gumb.

Učinimo ga funkcionalnim

Ovdje navedenu skriptu treba kopirati u novi modul. Ne zaboravite spremiti radnu knjigu kao datoteku radne knjige s omogućenim makronaredbama. Sub "FindThis" trebao bi biti priložen gumbu koji smo upravo izradili.

Isprobajmo ga

Dodajte adresu zajedno s ostalim informacijama u odgovarajuće stupce. Pritisnite gumb za pokretanje makronaredbe koja bi prikazala koordinate širine i dužine za sve adrese navedene na listu. Makro će start u retku 2 i nastavit će se izvoditi dok ne dođe do praznog retka.

Kako radi?

Skriptom smo izradili dvije funkcije. Jedan za dohvaćanje Lat vrijednosti i drugi za dohvaćanje Long vrijednosti. Koristeći FOR petlju, svaku adresu prosljeđujemo ovim funkcijama i prikazujemo rezultat na zaslonu.

Script

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

Ako pomoću skripte ne dobijete odgovarajuće rezultate, vjerojatni razlog može biti oštećen excel. Zatim možete koristiti Alat za oporavak Excel datoteka poput DataNumen Excel Repair popraviti Excel.

Uvod za autora:

Nick Vipond je stručnjak za oporavak podataka u DataNumen, Inc., koji je svjetski lider u tehnologijama za oporavak podataka, uključujući popravi problem dok i softverski proizvodi za oporavak Outlooka. Za više informacija posjetite www.datanumen.com