VBA Macro to pull contact numbers of companies from a site in to excel.

Kaarthick · Nov 30, 2016

Hi All,

I have a Company Name in the excel sheet 01, when i copy and paste 1 company name(example - LANDCO CONTRACTING) into excel sheet 02 and RUN MACRO/Click Enter, the following field must automatically fetch contact number from the website (www.canpages.ca) and populate into excel sheet 02 below the company name.

Grateful if anyone can help me with the logic as i am new to VBA.

Thanks
Kaarthick

Ratan Bhushan · Nov 30, 2016

Can you please share the workbook... along with more specific examples and desired results?>

Chihiro · Nov 30, 2016

FYI - You won't be able to do it with company name alone. That site requires city/postal code along with company name as parameter.

Ratan Bhushan · Nov 30, 2016

But when I entered only "LANDCO CONTRACTING" on the site, it gave back two records... he is looking for those two records.

Kaarthick · Nov 30, 2016

Hi Sir's - Thanks for your quick revert back. As requested, i am attaching the sample data of company lists along with the "Desired Output" it must populate.

Site Name - www.canpages.ca

Your help on this is highly appreciated & grateful.

Thanks
Kaarthick

Ratan Bhushan · Nov 30, 2016

Kaarthick said:
Hi Sir's - Thanks for your quick revert back. As requested, i am attaching the sample data of company lists along with the "Desired Output" it must populate.

Site Name - www.canpages.ca

Your help on this is highly appreciated & grateful.

Thanks
Kaarthick

you have forgot to attach the file.

Kaarthick · Nov 30, 2016

Hi Sir's - Sorry the attachment of excel is not accepting. I am pasting here the content of the company names + output format required.
Company Names

Address1

Address2
RENOVATORS BIN FLEET INC PO BOX 42105 CALGARY

ASPECT ARTS PHOTOGRAPHY 2054 DALE PL KAMLOOPS
LANDCO CONTRACTING 4745 SEABIRD ISLAND RD AGASSIZ
A Z PAWN SHOP 1917 DAYTON ST KELOWNA
SILVERMAN DR MARK 1081 CARLING AVE OTTAWA
FRIENDS DAY CARE 6551 MAIN ST STOUFFVILLE
MIKE S CONCRETE 53 ALDERSON DR HAMILTON
THE HAMILTON WENTWORTH DISTRICT SCHOOL BOARD 1175 MAIN ST E HAMILTON
SALON BIJOU 211 CARLTON ST TORONTO

Desired Output -
Company Name ASPECT ARTS PHOTOGRAPHY
Address1 2054 DALE PL
Address2 KAMLOOPS
Contact Number to be populated by the code
Website to be populated by the code

Chihiro · Nov 30, 2016

@Ratan Bhushan

See params that's being sent to list.jsp

So city name is translated to Postal Code first. Then ct & na is used as parameter for request.

Chihiro · Nov 30, 2016

Here's sample. That does it in same sheet. Adjust as needed.

I changed website from www.canpages.ca to YellowPages. Since www.canpages.ca uses YellowPages to get info anyways.

To avoid issue with number of requests limit, uses IE to open URL and then reads the HTML.Document.

Code:

Sub Test()
Dim ie As Object, ieDoc As Object
Dim tagOne As Object, tagTwo As Object
Dim i As Integer
Dim cName As String
Dim cel As Range
Dim x As Variant

Set ie = CreateObject("InternetExplorer.Application")

For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If cel.Offset(, 3) = "" Then
        cName = Replace(cel.Value, " ", "+")
       
        Url = "http://www.yellowpages.ca/search/si/1/" & cName & "/" & cel.Offset(, 2).Value
       
        ie.navigate Url
       
        Do Until (ie.readyState = 4 And Not ie.Busy)
            DoEvents
        Loop
        Set ieDoc = ie.Document
       
        Set tagOne = ieDoc.getElementsByTagName("a")
       
       
        For i = 1 To tagOne.Length
        On Error GoTo ErrHandle1:
            If InStr(1, tagOne.Item(i).href, "gourl") > 0 Then
                x = Split(tagOne.Item(i).href, "?")
                cel.Offset(, 4).Value = x(UBound(x))
                Exit For
            End If
ErrHandle1:
            Resume ErrHandle2:
ErrHandle2:
        Next
       
        Set tagTwo = ieDoc.getElementsByTagName("li")
       
       
        For i = 1 To tagTwo.Length
        On Error GoTo ErrHandle3:
            If phoneCheck(tagTwo.Item(i).innerText) Then
                cel.Offset(, 3).Value = tagTwo.Item(i).innerText
                Exit For
            End If
ErrHandle3:
            Resume ErrHandle4:
ErrHandle4:
        Next
    End If
Next cel

Set ie = Nothing
MsgBox "Process Complete"
End Sub

Public Function phoneCheck(pStr As String) As Boolean
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
    .Pattern = "^\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})$"
End With

phoneCheck = regex.Test(pStr)
End Function

Did test for first 3 company with no issue. See attached sample as well.

Kaarthick · Nov 30, 2016

Sir - Thanks a lot for your help. How do i run it. I must turn on the macro and run it.

Sorry if i am bothering too much.

Thanks
Kaarthick

Chihiro · Nov 30, 2016

While you have Sheet1 of the workbook active...

Press Alt+F8

Select "Test" macro and run it.

Kaarthick · Dec 1, 2016

Hi Sir,

I tested the macros for 50 companies, and found there are mismatch in address from the site (yellowpages.com) against the "google.ca" site where i manually searched and got the exact contact numbers.

Can we search the "Company Names + Address1 + Address2" from "google.ca" and when searched, the result that comes based on the search, it must autopopulate the contact numbers which is there in the search result link in to excel. For ex. in Google.ca - Enter - 'MCGRATH GERARD - 28 FRECKER PL - DUNVILLE' and it displays the correct contact number from the search results.
Your help on this highly appreciated.
Thanks
Kaarthick

Chihiro · Dec 1, 2016

Google search isn't ideal for searching contact number etc. Since you can't be sure that it will appear as first link. Unlike human eyes, code will need structured reference to pull info.

I modified the code to get "Listing Name" in Column F. You can verify if the name is match/similar to Column A and if not, do manual search.

Kaarthick · Dec 1, 2016

Sir - Thanks again, but the listing in the site is not correct. If the link (yellowpages.com i.e. canpages.ca) is not throwing correct address, i need to pull from other sites which is listed below -

www.Canada411.ca
www.londonchambers.com
http://www.ic.gc.ca/eic/site/ict-tic.nsf/eng/h_it06169.html
http://www.canadianbusinessdirectory.ca/
http://www.canadianbusinessdirectory.ca/
Also i need to include subsequent columns for the above sites as well. in the output file.

Your help on this is highly appreciated.

Thanks
Kaarthick

Chihiro · Dec 1, 2016

So do a check and tell me which one gives you correct listing for all. You've got to do some leg work for me.

I'm not about to write code for each one, nor will I test for each site.

Unless there is definitive source, you'll have to live with some manual check.

Code for above optimized a bit.

Code:

Sub Test()
Dim ie As Object, ieDoc As Object
Dim i As Integer
Dim cName As String, tagcName As String, tagPhone As String
Dim cel As Range
Dim x As Variant

Set ie = CreateObject("InternetExplorer.Application")

For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If cel.Offset(, 3) = "" Then
        cName = Replace(cel.Value, " ", "+")
       
        Url = "http://www.yellowpages.ca/search/si/1/" & cName & "/" & cel.Offset(, 2).Value
       
        ie.navigate Url
       
        Do Until (ie.readyState = 4 And Not ie.Busy)
            DoEvents
        Loop
        Set ieDoc = ie.Document
       
        tagcName = ieDoc.getElementsByClassName("listing__name--link jsListingName")(0).innerHTML

        cel.Offset(, 5).Value = tagcName

        On Error GoTo Skip1:
        tagLink = ieDoc.getElementsByClassName("mlr__item__cta")(0).href
        x = Split(tagLink, "?")
        cel.Offset(, 4).Value = x(UBound(x))
Skip1:
        On Error GoTo Skip2:
        tagPhone = ieDoc.getElementsByClassName("mlr__submenu__item")(0).innerText
        cel.Offset(, 3).Value = tagPhone
Skip2:
    End If
Next cel

Set ie = Nothing
'MsgBox "Process Complete"
End Sub

Public Function phoneCheck(pStr As String) As Boolean
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
    .Pattern = "^\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})$"
End With

phoneCheck = regex.Test(pStr)
End Function

Chihiro · Dec 1, 2016

FYI - "ASPECT ARTS PHOTOGRAPHY" is not registered to any of above data bases/sites. Also, Canada411 uses YellowPages for their query as well.

Kaarthick · Dec 1, 2016

Sir, Thanks for the revert back. I got an error while running the list. Attaching the same from my side. Adding to it, grateful if you can let me help for other sites checking. i am totally stuck on this as i need to move with this.

I await for your reply. Sorry again to bother you much on this.

Thanks
Kaarthick

Chihiro · Dec 1, 2016

Replace previous code with below.

Code:

Sub Test()
Dim ie As Object, ieDoc As Object
Dim i As Integer
Dim cName As String, tagcName As String, tagPhone As String
Dim cel As Range
Dim x As Variant

Set ie = CreateObject("InternetExplorer.Application")

For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If cel.Offset(, 3) = "" Then
        cName = Replace(cel.Value, " ", "+")
     
        Url = "http://www.yellowpages.ca/search/si/1/" & cName & "/" & cel.Offset(, 2).Value
     
        ie.navigate Url
     
        Do Until (ie.readyState = 4 And Not ie.Busy)
            DoEvents
        Loop
        Set ieDoc = ie.Document
       
        On Error GoTo Skip:
        tagcName = ieDoc.getElementsByClassName("listing__name--link jsListingName")(0).innerHTML
        cel.Offset(, 5).Value = tagcName
Skip:
        On Error GoTo Skip1:
        tagLink = ieDoc.getElementsByClassName("mlr__item__cta")(0).href
        x = Split(tagLink, "?")
        cel.Offset(, 4).Value = x(UBound(x))
Skip1:
        On Error GoTo Skip2:
        tagPhone = ieDoc.getElementsByClassName("mlr__submenu__item")(0).innerText
        cel.Offset(, 3).Value = tagPhone
Skip2:
    End If
Next cel

Set ie = Nothing
'MsgBox "Process Complete"
End Sub

Kaarthick · Dec 2, 2016

Sir - I am still getting the following error when i run the above code. Grateful, if you can provide your helping hand on this.

Thanks
Kaarthick

Chihiro · Dec 2, 2016

Upload workbook. I can't reproduce error on my end.

If you have trouble uploading excel workbook. Just change file extension to ".doc" or text.

Kaarthick · Dec 2, 2016

Hi Sir - Thanks for reverting back. I have attached the sample data for testing. Grateful if you can let me know on this.

Regards
Kaarthick

Chihiro · Dec 2, 2016

See attached.

Some company names were not found so returned above error.

Added string check to avoid issue. Now, if company isn't found, it will return "not found" in column C.

I also noticed some spelling mistakes in Company name. You'll want to correct that (Ex: WALSH JEROME FINANICAL SERVICES, should be Financial).

Kaarthick · Dec 2, 2016

Sir - Thank you so much. Found it useful & perfect. Again thanks for your time.

Regards
Kaarthick

Kaarthick · Dec 13, 2016

Sir - Grateful if you can help out on this. I need to extract contact numbers & website from "www.manta.com" as well adding to the previous results. Attaching the list of companies. Also i need to add similar columns like in the sheet which you have attached (latest one - CompanyContact_Rev-8.xlsb).

Your help on this is highly appreciated & thanks in advance.

Regards,
Kaarthick

Chihiro · Dec 13, 2016

I'm not sure I get you. Upload sample workbook with few lines of expected output.

VBA Macro to pull contact numbers of companies from a site in to excel.

New Member

Member

Excel Ninja

Member

New Member

Member

New Member

Excel Ninja

Excel Ninja

Attachments

New Member

Excel Ninja

New Member

Attachments

Excel Ninja

Attachments

New Member

Excel Ninja

Excel Ninja

New Member

Attachments

Excel Ninja

New Member

Attachments

Excel Ninja

New Member

Attachments

Excel Ninja

Attachments

New Member

New Member

Attachments

Excel Ninja