Alternatively, you can download the full list of USA zip codes and just embed
it in your workbook- for example, www.zipcodeworld.com (look at the 'free'
option) I think has zips with city name. I did a little more searching a
month or two ago and found a free database online that had zip, city, state,
latitude, and longitude. If you decide to go this route but can't find what
you are looking for, post back and we can connect offline.

HTH,
Keith

"Bernie Deitrick" wrote:

Jim,

The function code below will return the post office's city, used like

=ZipToPostOffice("30339")
or
=ZipToPostOffice(30339)
or
=ZipToPostOffice(A2)
where A2 has 30339

Any of these will return "ATLANTA, GA"

HTH,
Bernie
MS Excel MVP

Function ZipToPostOffice(ZIP5 As String) As String

Dim ie As Object
Dim sResult As String
Dim sCityState As String
Dim lStartZip As Long
Dim dtTimer As Date
Dim lAddTime As Long

Const sUPSURL As String = "http://zip4.usps.com/zip4/citytown_zip.jsp"
'"http://zip4.usps.com/zip4/welcome.jsp"
Const lREADYSTATE_COMPLETE As Long = 4

Set ie = CreateObject("InternetExplorer.Application")
ie.silent = True
ie.navigate "http://zip4.usps.com/zip4/citytown_zip.jsp"
'"http://zip4.usps.com/zip4/welcome.jsp"

dtTimer = Now
lAddTime = TimeValue("00:00:20")

Do Until ie.readystate = lREADYSTATE_COMPLETE And Not ie.busy
DoEvents
If dtTimer + lAddTime Now Then Exit Do
Loop

ie.document.form1.ZIP5.Value = ZIP5
ie.document.form1.submit

dtTimer = Now
lAddTime = TimeValue("00:00:20")

Do Until ie.readystate = lREADYSTATE_COMPLETE And Not ie.busy
DoEvents
If dtTimer + lAddTime Now Then Exit Do
Loop

sResult = ie.document.body.innertext
lStartZip = InStr(1, sResult, ZIP5, vbTextCompare)
lStartZip = InStr(lStartZip + 1, sResult, ZIP5, vbTextCompare)
If lStartZip 0 Then
ZipToPostOffice = Mid(sResult, lStartZip + 10, 100)
ZipToPostOffice = Mid(ZipToPostOffice, 1, InStr(1, ZipToPostOffice, Chr(13)) - 1)
Else
ZipToPostOffice = "Not Found"
End If

ie.Quit
Set ie = Nothing

End Function


"Jim" wrote in message
...

I am trying to read a the Post Office web page after I submit a zip code. The
following is what I have copied from anther site and have modified. The
orginal code had "Set objTable = objDoc.getElementById("idTable")" to
"Set objTable = objDoc.getElementsByTagName("table")" due to the table not
having an id. Being new at programming, I'm not sure as to what I'm doing
wrong.

It will work until I get to Set objCell = objTable.Rows(c), then I take an
error. My
code is as follows:

Sub MFHLookup()

Dim objIE As Object
Dim objDoc As Object
Dim objTable As Object
Dim objCell As Object
Dim FormValue As String
Dim Anymore As Boolean
Dim Found As Boolean
Dim c

Do Until Anymore = True

FormValue = ActiveCell.Value

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = False
objIE.Navigate "http://zip4.usps.com/zip4/citytown_zip.jsp"
Do While objIE.Busy: DoEvents: Loop
Do While objIE.ReadyState < 4: DoEvents: Loop
objIE.Visible = True
With objIE
.Document.getElementById("zip5").Focus
.Document.getElementById("zip5").Value = "30339"
.Document.getElementById("submit").Click
Do While .Busy: DoEvents: Loop
Do While .ReadyState < 4: DoEvents: Loop
End With

Set objDoc = objIE.Document
Set objTable = objDoc.getElementsByTagName("table")
c = 20

Set objCell = objTable.Rows(c)

If Trim(objCell.InnerText) < "30339" Then
Do Until Found = True
c = c + 1
Set objCell = objTable.Cells(c)
If Trim(objCell.InnerText) < "30339" Then
Found = False
Else
Found = True
End If
Loop
Else
End If

c = c + 1

Set objCell = objTable.Cells(c)

ActiveCell.Offset(0, 1).Value = Trim(objCell.InnerText)

objIE.Quit

Set objIE = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Set objCell = Nothing

ActiveCell.Offset(1, 0).Select

Anymore = IsEmpty(ActiveCell.Value)

Loop

ActiveWorkbook.Save

End Sub

Thanks for the help,
Jim