Work anywhere from any device with Microsoft 365

Upgrade to Microsoft 365 to work anywhere with the latest features and updates.

Upgrade now

Get Zip Code function in VBA

I want to automatically retrieve US postal zip codes using Excel VBA.  I can show the zip code, but I have to copy in from the USPS website.  I would like to the zip code go into a variable automatically, without my copying it.  Here is what I have so far.

Sub GetZipcode()
    Dim Z1 As String
    Dim Z2 As String
    Dim Z3 As String
    Dim I As Integer
    Dim Irow As Integer
    Dim objIE As Object
   
    Set objIE = Nothing
    Set objIE = CreateObject("InternetExplorer.Application")
   
    Sheets("Events").Select
    Irow = ActiveCell.Row
    Z1 = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=0&companyName=&address1="
    Z2 = Cells(Irow, 8).Value   ' address without state
    I = InStr(1, Z2, ";")
    If I > 0 Then
        If InStr(1, Z2, ",") > 0 Then
            Z2 = Right(Z2, Len(Z2) - 1 - InStr(1, Z2, ","))
            I = InStr(1, Z2, ";")
        End If
        Z2 = Left(Z2, I - 1) & "&city=" & Trim(Right(Z2, Len(Z2) - I - 1)) & "&state=CA"
        Z3 = Z1 & Z2
        With objIE
            .Visible = True
            .navigate Z3
            Do While .readyState <> 4: DoEvents: Loop
        End With
        Z1 = InputBox("Zipcode? ", "Enter")
        Set objIE = Nothing
        Cells(Irow, 9) = Z1
    Else
        If Z2 > "" Then MsgBox "Cell must contain a "";"" between the address and the name of the city"
    End If
    Cells(Irow + 1, 9).Select
    Beep
End Sub

* Please try a lower page number.

* Please enter only numbers.

* Please try a lower page number.

* Please enter only numbers.

Here is the solution:

Function ZipCode(Addr1 As String) As String
' Uses USPS website to retrieve 9-digit zipcode
' Takes much longer than Google, but it returns 9 digit zipcode instead of the 5 digit zipcode
'
    Dim URL As String
    Dim AD As String
    Dim Ct As String
    Dim St As String
    Dim Data As String
    Dim Addr As String
    Dim Zip As String
    Dim I As Integer
    Dim ie As Object
    Dim ieDoc As Object
   
    Addr = Trim(Addr1)
    I = InStr(1, Addr, ", ")
    If I > 0 Then Addr = Right(Addr, Len(Addr) - I - 1)
    Addr = Addr & ", CA"
   
    I = InStr(1, Addr, ";")
    AD = Replace(Trim(Left(Addr, I - 1)), " ", "+")
    Ct = Replace(Trim(Right(Addr, Len(Addr) - I - 1)), " ", "+")
   
    URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=0&companyName=&address1="
    URL = URL & AD & "&address2=&city=" & Ct & "&state=" & St & _

     "&urbanCode=&postalCode=&zip="
   
    Set ie = CreateObject("InternetExplorer.Application")
    ie.navigate URL
   
    Do Until (ie.readyState = 4 And Not ie.Busy)
        DoEvents
    Loop
   
    Set ieDoc = ie.document
    Data = ieDoc.body.innerText
    Data = Right(Data, Len(Data) - 2400)
    If InStr(1, Data, "Unfortunately, this address wasn't found") > 0 Then
        ZipCode = "Zipcode Error"
    Else
        Data = Mid(Data, InStr(1, Data, "Here's the full address") + 94, 100)
        ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)
    End If
    Set ie = Nothing
    Set ieDoc = Nothing
End Function

1 person was helped by this reply

·

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Here is another solution using Google

Sub Lat_Lon_Zip(Address As String, Lat_Lon As String, Zip As String)
' http://forum.chandoo.org/threads/find-latitude-and-longitude-of-any-address-using-google-map-api-and-vba.7253/
' Uses Google to get latitude, longitude and zip code
'
    Dim A1 As String
    Dim sURL As String
    Dim BodyTxt As String
    Dim apan As String, la_t As String, lo_g As String
    Dim oXH As Object
    Dim aa As Integer
    Dim bb As Integer
   
   
'create web url
    A1 = Replace(Address & ", United States", " ", "+")
    sURL = "http://maps.googleapis.com/maps/api/geocode/xml?address=""" & A1 & ",+" & "&sensor=false"""
  
' browse url
    Set oXH = CreateObject("msxml2.xmlhttp")
    With oXH
        .Open "get", sURL, False
        .send
        BodyTxt = .responseText
    End With
    apan = Application.WorksheetFunction.Trim(BodyTxt)
    Set oXH = Nothing
   
' Zip code
    Zip = Mid(apan, InStr(1, apan, "<type>postal_code</type>") - 20, 5)
   
'Latitude
    apan = Right(apan, Len(apan) - InStr(1, apan, "<lat>") - 4)
    la_t = Left(apan, InStr(1, apan, "</lat>") - 1)
'Longitude
    apan = Right(apan, Len(apan) - InStr(1, apan, "<lng>") - 4)
    lo_g = Left(apan, InStr(1, apan, "</lng>") - 1)
   
    Lat_Lon = DectoAngle(la_t & ", " & lo_g)
End Sub

'

Function DectoAngle(TT As String) As String
   
    Dim Num As Integer
    Dim SS As String
    Dim Deg As Integer
    Dim Min As Integer
    Dim Sec As Integer
   
    Dim K As Long
    Dim Lat As Double
    Dim Lon As Double
    Dim SS1 As Double
   
    Dim DirLat As String
    Dim DirLon As String
       
    K = InStr(TT, ",")
    Lat = Val(Left(TT, K - 1))
    Lon = Val(Right(TT, Len(TT) - K - 1))
   
    DirLat = "N"
    If Lat < 0 Then
        Lat = -Lat
        DirLat = "S"
    End If
   
    DirLon = "E"
    If Lon < 0 Then
        Lon = -Lon
        DirLon = "W"
    End If
   
    Deg = Int(Lat)
    SS1 = (Lat - Deg) * 60#
    Min = Int(SS1)
    Sec = Int((SS1 - Min) * 60# + 0.5)
    If Sec = 60 Then
        Min = Min + 1
        Sec = 0
    End If
    If Min = 60 Then
        Deg = Deg + 1
        Min = 0
    End If
   
    SS = Min
    If Min < 10 Then SS = "0" & Min
    SS = Deg & "°" & SS & "'"
    If Sec < 10 Then SS = SS & "0"
    SS = SS & Sec & Chr(34) & DirLat
   
    Deg = Int(Lon)
    SS1 = (Lon - Deg) * 60#
    Min = Int(SS1)
    Sec = Int((SS1 - Min) * 60# + 0.5)
    If Sec = 60 Then
        Min = Min + 1
        Sec = 0
    End If
    If Min = 60 Then
        Deg = Deg + 1
        Min = 0
    End If
   
    TT = Min
    If Min < 10 Then TT = "0" & Min
    TT = Deg & "°" & TT & "'"
    If Sec < 10 Then TT = TT & "0"
    TT = TT & Sec & Chr(34) & DirLon
   
    DectoAngle = SS & ", " & TT
   
End Function

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

James Benet,

Can you please explain how to implement this into excel? And maybe show me how the sample data should be formatted for it to work?  (In either Excel or google sheets)

I REALLY hope this works, it's exactly what I'm looking for.

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Run this macro

Sub Test1()
'
    Dim Address1 As String
    Dim Lat_Lon1 As String
    Dim Zip1 As String
   
    Address1 = "1600 Pennsylvania Ave, Washington, DC"
    Call Lat_Lon_Zip(Address1, Lat_Lon1, Zip1)
    MsgBox Lat_Lon1
    MsgBox Zip1
End Sub

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

I occasionally (too often) get an automation error. Why?

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

My apologies for posting on an older thread, but I cant find anything close to this so far. Is there a way provide the full 9 didgit zipcode with this?

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Look at my post above dated January 26, 2015, "Function ZipCode(Addr1 As String) As String".  This function returns the nine digit zipcode from the USPS website.

Jim Benet

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Ok, that worked now thankyou! I have an issue when there are multiple returns. How can I grab the first one returned? I tried this and the zipcode field comes back as blank..    

         Data = Mid(Data, InStr(1, Data, "Several addresses matched the information you provided. Perhaps you didn't enter a street number or the")+ 94, 100)
         ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)

Almost as though there is more space than the other pop up screens and its not finding the information.

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

I do not know.  Why don't you look what is inside the Data variable?  Are there zip codes buried inside?  If so, you should be able to fish them out.  If not, then just use the Google 5-digit routine.   I cannot duplicate and analyze your results without having your input data.  If that data is private we can continue off forum.  My email address is *** Email address is removed for privacy ***.

Jim Benet

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Looks like they removed the email address.. So lets use these two addresses, they are pretty well known. Oddly enough just down the street from each other. They have multiple returns for plus four. I just want to select the first one.

Trump Plaza

725 5th Ave; New York; NY; 10022

Clinton Foundation

1271 6TH AVENUE; New York; NY; 10020

Here is how I implemented your version of code to work for me.

Function ZipCode(Addr1 As String) As String
 ' Uses USPS website to retrieve 9-digit zipcode
 ' Takes much longer than Google, but it returns 9 digit zipcode instead of the 5 digit zipcode
 '
     Dim URL As String
     Dim AD As String
     Dim Ct As String
     Dim St As String
     Dim Data As String
     Dim Addr As String
     Dim Zip As String
     Dim I As Integer
     Dim ie As Object
     Dim ieDoc As Object
    
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[2]C"
    Range("A1").Select
    
     Addr = Trim(Addr1)
     I = InStr(1, Addr, ", ")
     If I > 0 Then Addr = Right(Addr, Len(Addr) - I - 1)
     Addr = Addr
    
     I = InStr(1, Addr, ";")
     AD = Replace(Trim(Left(Addr, I - 1)), " ", "+")
     Ct = Replace(Trim(Right(Addr, Len(Addr) - I - 1)), " ", "+")
    
     URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=0&companyName=&address1="
     URL = URL & AD & "&address2=&city=" & Ct & "&state=" & St & _
     "&urbanCode=&postalCode=&zip="
    
     Set ie = CreateObject("InternetExplorer.Application")
     ie.Navigate URL
     ie.Visible = True
     Do Until (ie.readyState = 4 And Not ie.Busy)
         DoEvents
     Loop
    
     Set ieDoc = ie.Document
     Data = ieDoc.body.innerText
     Data = Right(Data, Len(Data) - 2400)
    
     If InStr(1, Data, "Unfortunately, this address wasn't found") > 0 Then
         ZipCode = "Zipcode Error"
'
'    If InStr(2, Data, "building has multiple units") > 0 Then
'    ZipCode = "Several Addresses"
        
    ElseIf InStr(1, Data, "Here's the full address, using standard abbreviations and formatting...") > 0 Then
    ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)
   
   'Else
  
   ElseIf InStr(1, Data, "Several addresses matched") > 0 Then '- 1, 26)
   ZipCode = Mid(Data, InStr(1, Data, "-") - 50, 10)
  ' ZipCode = "*"
    End If
'     End If
'      End If
  '
  
'   On Error GoTo InvalidValue2:
''
''' On Error GoTo 0
'''
''
''
''
'InvalidValue2:
''
'    Data = Mid(Data, InStr(1, Data, "Several addresses matched") + 94, 100)
'    ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)
'
 
   
     Sheets("Sheet1").Range("g1").End(xlDown).Offset(1).Select
     Selection = ZipCode
    
         Sheets("sheet1").Range("a3").Select
   Selection.Delete Shift:=xlUp
  
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[2]C"
    Range("A1").Select
    
     Set ie = Nothing
     Set ieDoc = Nothing
 End Function
 
 
 Sub addresstest()
 
' Do Until Sheets("sheet1").Range("a1").Value = ""

 Call ZipCode(Sheets("sheet1").Range("a1").Value)

'Loop

 
 
 End Sub

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

* Please try a lower page number.

* Please enter only numbers.

* Please try a lower page number.

* Please enter only numbers.

 
 

Question Info


Last updated June 15, 2020 Views 6,832 Applies to: