VBA throwing runtime error with new data in table

Neasley

New Member
Joined
Sep 11, 2015
Messages
2
Hello Everyone. This is my first time posting, but I hope someone can help because I am going batty.

I have attempted to use VBA to get Zip +4 zip codes from usps website. Everything was going fine with sample data, but when I copied new data into the table, I start getting a runtime 5 error: Invalid procedure call or argument.

Here is my data

AddressCityStateZipcodeZipZip4
1642Harmon+StreetBerkeleyca947032636
2Peabody+TerraceCambridgema021386211
1600Pennsylvania+AveWashingtonDC205000003
1280N+Frontage+Rd+WVailCO816574457
3505th+AveNew+YorkNY101180110
3Christine DrBarrington RI02806
2100Channing+WayBerkeleyCA94720
1642Harmon+StreetBerkeleyca94703
2Peabody+TerraceCambridgema02138
1600Pennsylvania+AveWashingtonDC20500
1280N+Frontage+Rd+WVailCO81657
3505th+AveNew+YorkNY10118
1111S+Figueroa+StLos+AngelesCA90015
2100Channing+WayBerkeleyCA94720


<colgroup><col><col><col><col span="2"><col></colgroup><tbody>
</tbody>

My VBA code keeps stopping at the the 6th entry (3 Christine Dr Barrington RI 02806)

Sub ZipLookUp()
Dim URL As String, xmlHTTP As Object, html As Object, htmlResponse As String
Dim SStr As String, EStr As String, EndS As Integer, StartS As Integer
Dim Zip4Digit As String


Dim number As String
Dim address As String
Dim city As String
Dim state As String
Dim zipcode As String
Dim abc As String
Dim cell As Range


For Each cell In Range("C2:C15")
number = Sheet1.Range("A" & cell.Row)
address = Sheet1.Range("B" & cell.Row)
city = Sheet1.Range("C" & cell.Row)
state = Sheet1.Range("D" & cell.Row)
zipcode = Sheet1.Range("E" & cell.Row)


URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1="
URL = URL & number & "+" & address & "&address2=&city=" & city & "&state=" & state & "&urbanCode=&postalCode=&zip=" & zipcode
Set xmlHTTP = CreateObject("MSXML2.XMLHTTP")
xmlHTTP.Open "GET", URL, False
On Error GoTo NoConnect
xmlHTTP.send
On Error GoTo 0
Set html = CreateObject("htmlfile")
htmlResponse = xmlHTTP.responseText
If htmlResponse = Null Then
MsgBox ("Aborted - HTML response was null")
GoTo End_Prog
End If


SStr = "<span class=""zip4"">": EStr = "</span><br />" 'Searches for a string within 2 strings
StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr)
EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare)
Zip4Digit = Left(Mid(htmlResponse, StartS, EndS - StartS), 4)


Sheet1.Range("F" & cell.Row).Value = Zip4Digit


GoTo End_Prog
NoConnect:
If Err = -2147467259 Or Err = -2146697211 Then MsgBox "Error - No Connection": GoTo End_Prog 'MsgBox Err & ": " & Error(Err)
End_Prog:
Next cell


the VBA runs as expected until I reach this entry, and then upon hitting the Sheet1 line, I get the arrow.

Can Someone help me please?
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
If these are both true:

SStr = "": EStr = ""

How can you extract the four digits? It's nonsensical to find a zero-length string within a longer string. StartS and EndS are both zero, and no +4 is returned. I suspect you didn't notice that since the column was partially populated.

I did get a response string from the query, but it was too much to read through to try to figure out what SStr and EStr should have been.
 
Upvote 0
You're looping without delay.
Are you sure you aren't getting cut off by batch processing to the Post Office's zip lookup?
Hitting it too often will get you blocked.


that a side. you have these two vars empty. what are they suppose to find.
I see from the return html that the start string could be SStr = "class=""zip4"">"
And then change the zip4 fetch line to this Zip4Digit = Mid(htmlResponse, StartS, 4)
Code:
[COLOR=#ff0000]SStr = "": EStr = ""[/COLOR]
[COLOR=#333333]'Searches for a string within 2 strings[/COLOR]
[COLOR=#333333]StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr)[/COLOR]
[COLOR=#333333]EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare)[/COLOR]
[COLOR=#333333]Zip4Digit = Left(Mid(htmlResponse, StartS, EndS - StartS), 4)[/COLOR]
but i think youre getting cut off for batch proccessing.
 
Last edited:
Upvote 0
I delay would be a wonderful thing, even better would be a random delay, so it looks more human.
And what if you have an address that returns multiple zip plus 4 ie the addresses missing a building number or a unit number.
 
Upvote 0
Brucef-

Your edits were exactly what I needed. I knew that I was getting cut off for batch processing, but I was just running a test. With your edits the VBA was able to process my problem entries. Here is the updated code for anyone looking to do the same. Thanks again Brucef!

Sub ZipLookUp()
Dim URL As String, xmlHTTP As Object, html As Object, htmlResponse As String
Dim SStr As String, EStr As String, EndS As Integer, StartS As Integer
Dim Zip4Digit As String


Dim number As String
Dim address As String
Dim city As String
Dim state As String
Dim zipcode As String
Dim abc As String
Dim cell As Range


For Each cell In Range("C2:C1500")
newHour = Hour(Now())
newMinute = Minute(Now())
NewSecond = Second(Now()) + 5
waitTime = TimeSerial(newHour, newMinute, NewSecond)
Application.Wait waitTime


number = Sheet1.Range("A" & cell.Row)
address = Sheet1.Range("B" & cell.Row)
city = Sheet1.Range("C" & cell.Row)
state = Sheet1.Range("D" & cell.Row)
zipcode = Sheet1.Range("E" & cell.Row)


URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1="
URL = URL & number & "+" & address & "&address2=&city=" & city & "&state=" & state & "&urbanCode=&postalCode=&zip=" & zipcode
Set xmlHTTP = CreateObject("MSXML2.XMLHTTP")
xmlHTTP.Open "GET", URL, False
On Error GoTo NoConnect
xmlHTTP.send
On Error GoTo 0
Set html = CreateObject("htmlfile")
htmlResponse = xmlHTTP.responseText
If htmlResponse = Null Then
MsgBox ("Aborted - HTML response was null")
GoTo End_Prog
End If


SStr = "class=""zip4"">": EStr = "</span><br />" 'Searches for a string within 2 strings
StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr)
EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare)
Zip4Digit = Mid(htmlResponse, StartS, 4)


Sheet1.Range("F" & cell.Row).Value = Zip4Digit


GoTo End_Prog
NoConnect:
If Err = -2147467259 Or Err = -2146697211 Then MsgBox "Error - No Connection": GoTo End_Prog 'MsgBox Err & ": " & Error(Err)
End_Prog:
Next cell

End Sub
 
Upvote 0
Well, I tried your code and your data.
I changed these two lines and the code and ran just fine, finding all of them. Even added my own address just for giggles.
SStr = "class=""zip4"">"
Zip4Digit = Mid(htmlResponse, StartS, 4)
 
Upvote 0
You are more than welcome Neasley.
Here's a bonus back to you. I cleaned your code up a bit.
Removed orphan variables, Declared those that weren't,
took the Next statement out of error handler section and moved above where it should be).
User now has choice to continue or Quit if 'No Connection Found'.
Added the With ws so there's no need to reference 'Sheetx' Object for every action.
Changed the hardcoded 5 seconds wait, to a Random 10-20 seconds to keep from getting blocked by the Post Office for batch processing.
Also format the code so its easier to follow the With's...End with For Each...Next IF...End If
Got rid of your variable named 'cell' so it is not confused with Excel's Cell Object.
Added better error handling and messaging including letting the User know when the process is done.
Code:
Sub ZipLookUp() 
Dim sURL As String, xmlHTTP As Object, htmlResponse As String
Dim sStr As String, StartS As Integer
Dim Zip4Digit As String, Number As String, Address As String, City As String
Dim State As String, ZipCode As String
Dim x As Long, startRow As Long, EndRow As Long
Dim r As Range

Dim ws As Worksheet
Dim ErrAnsw As Long
Dim WaitTime As Variant, NewSec As Variant, NewMin As Variant, newHr As Variant


' ********************************************************************
' Token string to find in the returned html to get the zip4 number.
  sStr = "class=""zip4"">"
' ********************************************************************


Set ws = ActiveSheet
With ws
  ' ********************************************************************
    ' First cell with data below header.
    ' Can be any column that is sure to have data down the entire data set.
    ' Column B is good because all rows will have 'Address' data.
    Set r = .Range("B2")
  ' ********************************************************************
    startRow = r.Row
    ' Get the last row with data in the column.
    EndRow = .Cells(.Rows.Count, r.Column).End(xlUp).Row ' < allows a dynamic end row as data changes in sheet.


    For x = startRow To EndRow
        
        Debug.Print Now() ' Just for testing.
        
        newHr = Hour(Now())
        NewMin = Minute(Now())
        'newsecond = Second(Now()) + 5
        ' Five seconds is not very humban like.
        ' Lets do a random between 10 and 20 seconds the current seconds time so the server thinks we are a bit human like.
        ' Process with delay is a bit longer but getting blocked is even longer.
        Randomize
        NewSec = Second(Now()) + Int((20 - 10 + 1) * Rnd + 10)
        WaitTime = TimeSerial(newHr, NewMin, NewSec)
        
        Debug.Print WaitTime ' Just for testing.
        
        Application.Wait WaitTime
        
        Number = .Range("A" & x)
        Address = .Range("B" & x)
        City = .Range("C" & x)
        State = .Range("D" & x)
        ZipCode = .Range("E" & x)
        
        sURL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1="
        sURL = sURL & Number & "+" & Address & "&address2=&city=" & City & "&state=" & State & "&urbanCode=&postalCode=&zip=" & ZipCode
        
        Set xmlHTTP = CreateObject("MSXML2.XMLHTTP")
        xmlHTTP.Open "GET", sURL, False
        
        On Error GoTo NoConnect
        
        xmlHTTP.send
        On Error GoTo 0
        Set html = CreateObject("htmlfile")
        htmlResponse = xmlHTTP.responseText
        If htmlResponse = Null Then
            MsgBox "Aborted - HTML response was null", vbCritical
            Exit For
        End If
        
        StartS = InStr(1, htmlResponse, sStr, vbTextCompare) + Len(sStr)
        Zip4Digit = Mid(htmlResponse, StartS, 4)
        
        .Range("F" & x).Value = Zip4Digit
        
NextIteration:
    Next
End With


End_Prog:
    MsgBox "Done."
    Exit Sub


NoConnect:
    If Err = -2147467259 Or Err = -2146697211 Then
        ErrAnsw = MsgBox("No Connection to:" & vbCrLf & Left(sURL, 40) & "...." & vbCrLf _
                & "Do you want to continue processing the next address?", vbYesNo + vbInformation, "Error-No Connection")
        
        If ErrAnsw = vbYes Then GoTo NextIteration
        
    Else ' Tell user what the unspecified error is. Otherwise you'll **** them off with no feedback of the problem.
       MsgBox "Error Number: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Something is wrong."
    End If
    GoTo End_Prog
    
End Sub

And a friendly reminder, when posting your code to a message please use the CODE tags around your pasted code.
Next time you post a message, take notice of the # button to the right of the reply tool bar. To insert your code, Click the # , then paste your code inside the middle of it.
Or to find out more, Click here to see how to insert your code sample into a post without upsetting anyone, (especially Moderators)
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top