Web query to get zip code from Google or Yahoo!

'Using web query to get zip code from Google or Yahoo!
'This required street address, city, state fields.

Sub Get_Zip_Code_From_Google_Or_Yahoo()
Dim gurl As String
Dim qstr, cname, street, city, state, zip, street_city_state, street_city_state_1, street_city_state_2, street_city_state_3, street_city_state_4 As String
Dim rc1, rca2, rcb2, pos, pos1, pos2, pos3, pos4 As Integer
Dim tm As Single
rc1 = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
For i = 4144 To rc1
If Worksheets(1).Cells(i, 6) <> "" Then
GoTo again
End If
zip = ""
street_city_state = street_city_state_1 = street_city_state_2 = street_city_state_3 = street_city_state_3 = ""
pos = 0
cname = Replace(Worksheets(1).Cells(i, 2), "&", "%26")
street = Worksheets(1).Cells(i, 3)
city = Worksheets(1).Cells(i, 4)
state = Worksheets(1).Cells(i, 5)
street_city_state_1 = LCase(Trim(street)) & ", " & LCase(Trim(city)) & ", " & LCase(Trim(state))
street_city_state_2 = LCase(Trim(street)) & " " & LCase(Trim(city)) & ", " & LCase(Trim(state))
street_city_state_3 = LCase(Trim(street)) & " " & LCase(Trim(city)) & " " & LCase(Trim(state))
street_city_state_4 = LCase(Trim(street)) & ", " & LCase(Trim(city)) & ", " & LCase(Trim(state)) & ","
street_city_state_5 = LCase(Trim(street)) & " " & LCase(Trim(city)) & ", " & LCase(Trim(state)) & ","
qstr = cname & "+" & Worksheets(1).Cells(i, 3) & "+" & Worksheets(1).Cells(i, 4) & "+" & _
Worksheets(1).Cells(i, 5)
'google search
gurl = "http://www.google.com/search?q=" & qstr
'yahoo search
'gurl = "http://www.altavista.com/web/results?fr=altavista&itag=ody&q=" & qstr & "+&kgs=1&kls=0"
Worksheets(2).Activate
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & gurl, _
Destination:=Range("$A$1"))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

rca2 = Worksheets(2).Range("A" & Rows.Count).End(xlUp).Row
rcb2 = Worksheets(2).Range("B" & Rows.Count).End(xlUp).Row

For j = 1 To rcb2
pos = InStr(LCase(Worksheets(2).Cells(j, 2)), LCase(Trim(Worksheets(1).Cells(i, 4)) & ", " & Trim(Worksheets(1).Cells(i, 5))))
If pos > 0 Then
zip = Mid(Worksheets(2).Cells(j, 2), Len(Worksheets(1).Cells(i, 4)) + Len(Worksheets(1).Cells(i, 5)) + 2 + 2, Len(Worksheets(2).Cells(j, 2)))
If InStr(zip, "-") > 0 Then
Worksheets(1).Cells(i, 6) = Left(zip, InStr(zip, "-") - 1)
Else
Worksheets(1).Cells(i, 6) = zip
End If
Exit For
End If
Next

If j > rcb2 Then
For k = 1 To rca2
pos1 = InStr(LCase(Worksheets(2).Cells(k, 1)), street_city_state_1)
pos2 = InStr(LCase(Worksheets(2).Cells(k, 1)), street_city_state_2)
pos3 = InStr(LCase(Worksheets(2).Cells(k, 1)), street_city_state_3)
pos4 = InStr(LCase(Worksheets(2).Cells(k, 1)), street_city_state_4)
pos5 = InStr(LCase(Worksheets(2).Cells(k, 1)), street_city_state_5)

If pos1 > 0 Then
pos = pos1
street_city_state = street_city_state_1
ElseIf pos2 > 0 Then
pos = pos2
street_city_state = street_city_state_2
ElseIf pos3 > 0 Then
pos = pos3
street_city_state = street_city_state_3
ElseIf pos4 > 0 Then
pos = pos4
street_city_state = street_city_state_4
ElseIf pos5 > 0 Then
pos = pos5
street_city_state = street_city_state_5
Else
pos = 0
End If

If pos1 > 0 And pos4 > 0 Then
pos = pos + 1
End If

If pos2 > 0 And pos5 > 0 Then
pos = pos + 1
End If

If pos > 0 Then
zip = Trim(Mid(Worksheets(2).Cells(k, 1), pos + Len(street_city_state) + 1, 5))
If IsNumeric(zip) = True Then
Worksheets(1).Cells(i, 6) = zip
Exit For
End If
End If
Next
End If

Worksheets(2).Range("A:Z").Clear
tm = Timer
While (Timer - tm < 3)
Wend
again:
Next
End Sub

Macro to consolidate excel files into one

Sub File_Consolidation()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wkb1 As Workbook
Dim rcs, ccs, rct, cct As Integer
Dim awkb, fpath As String
'Folder path
fpath = "C:\Manivannan\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
awkb = ActiveWorkbook.Name
Set objFolder = objFSO.GetFolder(fpath)

For Each objFile In objFolder.Files
If InStr(objFile.Name, awkb) = 0 Then
Set wkb1 = Workbooks.Open(fpath & objFile.Name)
rct = Workbooks(awkb).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
rcs = wkb1.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
ccs = wkb1.Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column

'Files with header
'wkb1.Worksheets(1).Range(wkb1.Worksheets(1).Cells(2, 1), 'wkb1.Worksheets(1).Cells(rcs, ccs)).Copy _
' Destination:=Workbooks(awkb).Worksheets(1).Range("A" & rct + 1)

'Files without header
wkb1.Worksheets(1).Range(wkb1.Worksheets(1).Cells(1, 1), wkb1.Worksheets(1).Cells(rcs, ccs)).Copy _
Destination:=Workbooks(awkb).Worksheets(1).Range("A" & rct + 1)

Workbooks(awkb).Save
wkb1.Close SaveChanges:=False
End If
Next objFile
End Sub

Macro to get URL from hyperlink

'Friendly Name Hyperlink
'Google http://www.google.co.in/
'Yahoo! http://in.yahoo.com/

Function GetURL(Links As Range)
GetURL = Links.Hyperlinks(1).Address
End Function