VBA Internet Explorer Automation - Insert value from cell to input and retrieve result

exc4libur · Jul 30, 2014

I have a list of mobile numbers in column A:A and I wanted to find out what phone operator they belong to.

So, if you open the website link: http://www.qualoperadora.net/ and type inside the box "11976773331", the result will be the following:

Número11)97677-3331
Operadora: Claro - Celular
Portabilidade: Não
Estado: São Paulo

If anyone can help me accomplish this by VBA, I would very much appreciate it!

Hui · Jul 31, 2014

If you open that page using Excel
Goto Data, From Web
Enter the Telephone number
Then when the answer is returned you can click on the Yellow Arrow at the Top Left of the page
and insert it into your worksheet

exc4libur · Jul 31, 2014

Hui said:
If you open that page using Excel
Goto Data, From Web
Enter the Telephone number
Then when the answer is returned you can click on the Yellow Arrow at the Top Left of the page
and insert it into your worksheet

Hey Master Hui, thank you for replying.

So I tried what you suggested but the information I imported was different from the website.

Rgds,
Exc4.

Hui · Aug 2, 2014

Exc4

This was my first effort at extracting web data using VBA and the site isn't simple HTML so I was happy to get a result out

I hope you are happy with the outcome

Marc L · Aug 2, 2014

Hi !

I prefer pilot IE at end not to display it and close it (.quit before End With)
and detect when final webpage finishes to load (avoiding pause like Wait) …

But better than pilot IE, there is an alternative faster way !
Needs less than a second to grab all data located within ID resultato …

Try this demonstration in a new workbook,
must paste code to a worksheet module :

Code:

Sub DemoXML()
    Const HST$ = "www.qualoperadora.net", URL$ = "http://" & HST & "/", ELT$ = "resultado"

    With CreateObject("Microsoft.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Referer", URL
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "DNT", "1"
        .setRequestHeader "Host", HST
        On Error Resume Next
        .send "ref2115=" & URL & "&telefone=11976773331"
        On Error GoTo 0
        If .Status = 200 Then T$ = .ResponseText
    End With

    If InStr(T, ELT) Then
        With CreateObject("HTMLfile")
            .Write T

            If .parentWindow.clipboardData.setData("Text", .all(ELT).innerText) Then
                Application.ScreenUpdating = False:  [B2].CurrentRegion.Clear:  Me.Paste [B2]
               .parentWindow.clipboardData.clearData "Text"
            End If

            .Close
        End With
    Else
        Beep
    End If
    End
End Sub

exc4libur · Aug 2, 2014

Hui said:
If you open that page using Excel
Goto Data, From Web
Enter the Telephone number
Then when the answer is returned you can click on the Yellow Arrow at the Top Left of the page
and insert it into your worksheet

exc4libur said:
Hey Master Hui, thank you for replying.

So I tried what you suggested but the information I imported was different from the website.

Rgds,
Exc4.

Wow Hui! That's awesome, it worked perfectly.

Thank you very much!!!

exc4libur · Aug 2, 2014

Marc L said:

Hi !

I prefer pilot IE at end not to display it and close it (.quit before End With)
and detect when final webpage finishes to load (avoiding pause like Wait) …

But better than pilot IE, there is an alternative faster way !
Needs less than a second to grab all data located within ID resultato …

Try this demonstration in a new workbook, must paste code to a worksheet module :

Code:

Sub DemoXML()
    Const HST$ = "www.qualoperadora.net", URL$ = "http://" & HST & "/", ELT$ = "resultado"

    With CreateObject("Microsoft.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Referer", URL
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "DNT", "1"
        .setRequestHeader "Host", HST
        On Error Resume Next
        .send "ref2115=" & URL & "&telefone=11976773331"
        On Error GoTo 0
        If .Status = 200 Then T$ = .ResponseText
    End With

    If InStr(T, ELT) Then
        With CreateObject("HTMLfile")
            .Write T

            If .parentWindow.clipboardData.setData("Text", .all(ELT).innerText) Then
                Application.ScreenUpdating = False:  [B2].CurrentRegion.Clear:  Me.Paste [B2]
               .parentWindow.clipboardData.clearData "Text"
            End If

            .Close
        End With
    Else
        Beep
    End If
    End
End Sub

Hey Marc,

I tried the code but, there was an invalid use of keyword:

Code:

Application.ScreenUpdating = False:  [B2].CurrentRegion.Clear:  Me.Paste [B2]

Marc L · Aug 2, 2014

Works like a charm on my side on computers with different Excel versions ! Bad luck for you …

Or you didn't read and apply the advice line just before the code ‼ For sure …

To understand, select Me statement in code, hit F1 key and read …

exc4libur · Aug 2, 2014

AWESOMEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE

Marc L · Aug 2, 2014

When you enjoy a code, click on Like at its post bottom left, thanks !

exc4libur · Aug 2, 2014

I have the telephones lined up in column A, how do i change the code so that it runs through all of them?

Code:

 "&telefone=11976773331" [/]

Marc L · Aug 2, 2014

Attach an exact sample workbook within a worksheet with data at right place
and for the first item the data result expected …

Marc L · Aug 3, 2014

Assuming numbers in column A, results in column B and titles in row 1,
try this new demonstration (paste code to the data worksheet module) :

Code:

Sub DemoXMLnoe()
    Const HST$ = "www.qualoperadora.net", URL$ = "http://" & HST & "/", _
          SND$ = "ref2115=" & URL & "&telefone="

    Application.StatusBar = "        Web download …"
                      NOE = [A1].CurrentRegion.Columns(2).Value

    For R& = 2 To UBound(NOE)
        If NOE(R, 1) = "" Or Val(NOE(R, 1)) Then
            With CreateObject("Microsoft.XMLHTTP")
                .Open "POST", URL, False
                .setRequestHeader "Referer", URL
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .setRequestHeader "DNT", "1"
                .setRequestHeader "Host", HST
                On Error Resume Next
                .send SND & Cells(R, 1).Text
                On Error GoTo 0

                If .Status = 200 Then
                        S& = InStr(InStr(.ResponseText, "<title>") + 7, .ResponseText, " ") + 1
                    NOE(R, 1) = Mid(.ResponseText, S, InStr(S, .ResponseText, "</") - S)
                Else
                    NOE(R, 1) = .Status & " : " & .StatusText
                End If
            End With
        End If
    Next

    If R > 2 Then With [B1].Resize(UBound(NOE)): .Value = NOE: .Columns.AutoFit: End With
    Application.StatusBar = False:  End
End Sub

Enjoy it ! Moderate it according to your needs …

exc4libur · Jun 10, 2015

Marc L said:
Attach an exact sample workbook within a worksheet with data at right place
and for the first item the data result expected …

Hi Marc,

Could you help me, its been a while and I tried running the code today and it didn't work. Please find an example attached.

Rgds

Marc L · Jun 10, 2015

Can you detail the issue ?

Web page change ?

exc4libur · Jun 10, 2015

Marc L said:
Can you detail the issue ?

Web page change ?

Hey. So, the results we're coming as invalid. Then, suddenly, after running the subroutine again, an error appeared: "Run-time error '5': Invalid procedure cal or argument."

Marc L · Jun 11, 2015

The website is now protected … After a while, the IP address is blocked …

So you have to see in your webbrowser what changes in the request
or go back to pilot Internet Explorer …

Marc L · Jun 11, 2015

I just try to pilot IE, it works buf after a while :

« #Erro: Sessões excedidas para sua rede. »

So maybe you have to find out another website less protected …

Marc L · Jun 11, 2015

I was thinking I found a trick but after 5 phones numbers :

« ALERTA!
Consultas automatizadas não são permitidas,
caso insista seu acesso poderá ser negado. »

exc4libur · Jun 11, 2015

Marc L said:
I was thinking I found a trick but after 5 phones numbers :

« ALERTA!
Consultas automatizadas não são permitidas,
caso insista seu acesso poderá ser negado. »

Let me do a quick search for another website. Just a sec.

exc4libur · Jun 11, 2015

Found a couple:

http://qualoperadora.info/
http://consultaoperadora.com.br/
http://consultanumero.info/
https://www.qual-operadora.net/

Marc L · Jun 11, 2015

Seems to work with a pause after each click :

Code:

Sub DemoIE()
            Const MSG = "mensagem", RES = "resultado"
                   VA = Cells(1).CurrentRegion
Application.StatusBar = "        Web download …"

With CreateObject("InternetExplorer.Application")
    .Navigate "http://www.qualoperadora.net/"
    While .Busy Or .ReadyState < 4:  DoEvents:  Wend

    With .Document
        For R& = 2 To UBound(VA)
            If VA(R, 2) = "" Then
                .all("telefone").Value = VA(R, 1)
                .all("consultar").Click
                While .ReadyState <> "complete":  DoEvents:  Wend

                If IsObject(.all(RES)) Then
                    Cells(R, 2).Value = .all(RES).innerText
                    If R < UBound(VA) Then Application.Wait Now + 0.00003
                ElseIf IsObject(.all(MSG)) Then
                    T$ = .all(MSG).innerText
                    Exit For
                End If
            End If
        Next
    End With

    .Quit
End With

Application.StatusBar = False
If T > "" Then MsgBox T, vbExclamation, "  " & MSG
End Sub

You like ? So thanks to …

exc4libur · Jun 11, 2015

Marc L said:

Seems to work with a pause after each click :

Code:

Sub DemoIE()
            Const MSG = "mensagem", RES = "resultado"
                   VA = Cells(1).CurrentRegion
Application.StatusBar = "        Web download …"

With CreateObject("InternetExplorer.Application")
    .Navigate "http://www.qualoperadora.net/"
    While .Busy Or .ReadyState < 4:  DoEvents:  Wend

    With .Document
        For R& = 2 To UBound(VA)
            If VA(R, 2) = "" Then
                .all("telefone").Value = VA(R, 1)
                .all("consultar").Click
                While .ReadyState <> "complete":  DoEvents:  Wend

                If IsObject(.all(RES)) Then
                    Cells(R, 2).Value = .all(RES).innerText
                    If R < UBound(VA) Then Application.Wait Now + 0.00003
                ElseIf IsObject(.all(MSG)) Then
                    T$ = .all(MSG).innerText
                    Exit For
                End If
            End If
        Next
    End With

    .Quit
End With

Application.StatusBar = False
If T > "" Then MsgBox T, vbExclamation, "  " & MSG
End Sub

You like ? So thanks to …

YES!!!!!!!!!!!!!!

exc4libur · Jun 11, 2015

Hey, I tried modifying your XMLhttp code for:
http://www.qual-operadora.net/ and it works. But I don't know to change the part of the code to get the information I need.

Marc L · Jun 12, 2015

On my side, I can't access qualoperadora.net, and you ?

Request depends too how the webpage is coded.
And with qual-operadora.net like consultaoperadora.com.br,
data are not in the response code, like a protection, using scripts …

Without a trick :

Code:

Sub DemoIE2()
VA = Cells(1).CurrentRegion

With CreateObject("InternetExplorer.Application")
    Application.StatusBar = "        Web download …"
    On Error GoTo NavEnd
    .Navigate "http://www.qual-operadora.net/"
    While .Busy Or .ReadyState < 4:  DoEvents:  Wend

    With .Document
        For R& = 2 To UBound(VA)
            If VA(R, 2) = "" Then
                With .forms(0)
                     .all("numero").Value = VA(R, 1)
                     .submit
                End With

                While .ReadyState <> "complete":  DoEvents:  Wend
                Cells(R, 2).Value = Replace$(Split(.forms(1).innerText, vbCrLf & "Quer")(0), vbCrLf & vbCrLf, vbLf)
            End If
        Next
    End With

NavEnd:
    Application.StatusBar = False
    .Quit
End With

If Err.Number Then Beep: If R Then Cells(R, 2).Value = "Err #" & Err.Number & " : " & Err.Description
End Sub

VBA Internet Explorer Automation - Insert value from cell to input and retrieve result

Member

Excel Ninja

Member

Excel Ninja

Attachments

Excel Ninja

Member

Member

Excel Ninja

Member

Excel Ninja

Member

Excel Ninja

Excel Ninja

Member

Attachments

Excel Ninja

Member

Excel Ninja

Excel Ninja

Excel Ninja

Member

Member

Excel Ninja

Member

Member

Excel Ninja