Excel VBA Macro to Scrape Webpages

jalexmiller0

New Member
Joined
Nov 10, 2017
Messages
8
Hi there, I am a complete beginner working on this macro. The goal is to have it input pickup numbers from an excel spreadsheet, put them on the carrier's website form, submit, then pull the results into excel. Which is essentially what I have managed to figure out so far. Now my roadblock is figuring out how to format it into excel so it's easy to read. (If there are more efficient ways to write what I already have please let me know.)


There is a lot of stuff commented out because I have been trying different techniques from all across the web. With varying amounts of success. I would like to get the code to put the results into the same worksheet as the pickup numbers. In the column next to the pickup number column so it can quickly be determined if the shipment has been picked up yet or not.
If that's not possible then outputting to a new sheet also works. Just so long as the information lines up with the corresponding pickup number.

Now on the carriers website after the code submits the pickup numbers. I need it to take "Shipment spotted on trailer JBHUXXXXXX" and if that isn't displayed. I need it to output "Arrived at destination service center" with the time and location as well. An example of this result is under 145-5244858-2.

Everything is stored in tables inside tables with the main table having "boxTableBorder" as the class name.

Code:
Sub TracePickupNumbers()

Dim IE As New SHDocVw.InternetExplorer
Dim HTMLDoc As MSHTML.HTMLDocument


IE.Visible = True
IE.navigate "http://www.centraltransportint.com/confirm/trace.aspx"


Do While IE.ReadyState <> READYSTATE_COMPLETE
Loop


Dim str As String
Dim arr() As Variant
Dim tablerow As Integer
Dim tablecol As Integer


arr = Range("A2:A7")


For tablerow = LBound(arr) To UBound(arr)
    For tablecol = LBound(arr, 2) To UBound(arr, 2)
        str = str & arr(tablerow, tablecol) & vbTab
    Next tablecol
    str = str & vbNewLine
Next tablerow


With IE.Document
    .all("_ctl0_lstType").Value = "PuN"
'    .all("_ctl0_lstType").fireevent.onchange() 'Gives syntax error
    .all("_ctl0:traceNumbers").innerText = "1"
    .all("_ctl0:traceSubmit").Click
End With


Application.Wait (Now + TimeValue("00:00:01"))


With IE.Document
    .all("_ctl0:traceNumbers").innerText = str
    .all("_ctl0:traceSubmit").Click
End With


Application.Wait (Now + TimeValue("00:00:02"))


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim HTMLElement As MSHTML.IHTMLElement
Dim HTMLElements As MSHTML.IHTMLElementCollection
Dim HTMLBody As MSHTML.IHTMLElement
Dim HTMLRow As MSHTML.IHTMLElement
Dim HTMLhh As MSHTML.IHTMLElement
Dim HTMLdates As MSHTML.IHTMLElement
Dim HTMLss As MSHTML.IHTMLElement
Dim Doc As HTMLDocument
Dim RowNum As Long, ColNum As Integer


Dim count As Long
Dim erow As Long


Application.Wait (Now + TimeValue("00:00:01"))


Set HTMLElements = IE.Document.getElementsByClassName("boxTableBorder")


'count = 0


For Each HTMLElement In HTMLElements


'    If HTMLElement.className = "boxTableBorder" Then
'
'        erow = ThisWorkbook.Sheets("pickups").Cells(Rows.count, 2).End(xlUp).Offset(1, 0).Row
'        Cells(erow, 2) = HTML.getElementsByClassName("hh")(count).innerText
'        Cells(erow, 3) = HTML.getElementsByClassName("dates")(count).innerText
'        Cells(erow, 4) = HTML.getElementsByClassName("ss")(count).innerText
'
'        count = count + 1
'
'    End If
    


'    ThisWorkbook.Sheets("pickups").Range("B2").Value = HTMLElement.className
'    Worksheets.Add
'    Range("A1").Value = HTMLElement.className
'
'    RowNum = 1
'
     For Each HTMLBody In HTMLElement.getElementsByTagName("tbody")
'    For Each HTMLRow In HTMLElement.getElementsByTagName("tbody")
        Debug.Print vbTab & HTMLBody.innerText
'
'        ColNum = 1
'        For Each HTMLCell In HTMLBody.Children
'        For Each HTMLCell In HTMLRow.Children
'        For Each HTMLhh In HTMLBody.getElementsByClassName("hh")
'            Debug.Print vbTab & HTMLhh.innerText
'
'        Next HTMLhh
'
'                For Each HTMLdates In HTMLBody.getElementsByClassName("dates")
'                    Debug.Print vbTab & HTMLdates.innerText
'
'                Next HTMLdates
'                        For Each HTMLss In HTMLBody.getElementsByClassName("ss")
'                            Debug.Print vbTab & HTMLss.innerText
''            Cells(RowNum, ColNum) = HTMLCell.innerText
''            ColNum = ColNum + 1
'                        Next HTMLss
        
        
        
'        RowNum = RowNum + 1
    Next HTMLBody
'    Next HTMLRow


Next HTMLElement


'Range("B2:C20").Select
'Columns("B:B").EntireColumn.AutoFit
'Columns("C:C").EntireColumn.AutoFit


IE.Quit
Set IE = Nothing


End Sub
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,747
Can you post some example pickup numbers and the data which should be extracted from the result page(s)?
 

jalexmiller0

New Member
Joined
Nov 10, 2017
Messages
8
For sure.

Here are a couple pickup numbers and the corresponding info for each one:

PU-958-111307203285

Pickup Scheduled for: 11/13/2017
Mon 11/13/2017 4:20 AM
SANTA FE SPRINGS, CA

<tbody>
</tbody>

PU-958-111307302567

Contact Customer Service @ (586) 467-1900.
Mon 11/13/2017 9:53 AM
COLTON, CA

PU-958-111307304061

<tbody>
</tbody>

Contact Customer Service @ (586) 467-1900.
Mon 11/13/2017 9:53 AM
ONTARIO, CA

PU-946-110109442013

<tbody>
</tbody>
Shipment was Spotted on Trailer JBHU280932


<tbody>
</tbody>

<tbody>
</tbody>
Thank you
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,747

ADVERTISEMENT

Try this code, which uses IE automation to search multiple pickup numbers at once and extract the results into the cell to the right of each pickup number. The pickup numbers are expected to be in the first worksheet in column A starting at A2.

You must set the two references noted at the top of the code, otherwise the code won't compile or run.

Tested and working on IE11, although the coding was quite tricky due to the way the web page works (I've no idea why it requires a dummy number to be input and traced first), and the fact that IE11 creates a second (hidden) window which the VBA IE object references instead of the correct window with the results. The only workaround I've found to fix this is to hide and show the IE window at certain places in the code, so you'll see the IE window disappearing and appearing when the macro is run.

Code:
'Set these references via Tools -> References in VBA editor:
'Microsoft Internet Controls
'Microsoft HTML Object Library


Option Explicit

'https://msdn.microsoft.com/en-us/library/office/gg264421.aspx
'64-Bit Visual Basic for Applications Overview

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    'New VBA version 7 compiler, therefore >= Office 2010
    'PtrSafe means function works in 32-bit and 64-bit Office
    'LongPtr type alias resolves to Long (32 bits) in 32-bit Office, or LongLong (64 bits) in 64-bit Office
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    'Old VBA version 6 or earlier compiler, therefore <= Office 2007
    Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Public Sub IE_Trace_Pickup_Numbers()
    
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim URL As String
    Dim pickupNumberCells As Range
    Dim traceSelect As HTMLSelectElement
    Dim traceTextArea As HTMLTextAreaElement
    Dim traceButton As HTMLInputButtonElement
    Dim traceNumbers As String
    Dim resultsDiv As HTMLDivElement
    Dim resultsTable As HTMLTable, infoTable As HTMLTable
    Dim infoTables As IHTMLElementCollection
    Dim i As Long
    Dim result As String
    Dim PuNumber As String, PuNumberRow As Variant
    
    'Get pickup numbers from column A in 1st sheet starting at A2
    
    With Worksheets(1)
        Set pickupNumberCells = .Range("A2", .Cells(Rows.count, "A").End(xlUp))
    End With
    pickupNumberCells.Offset(, 1).ClearContents
    traceNumbers = Join(Application.Transpose(pickupNumberCells), vbNewLine)
    
    URL = "http://www.centraltransportint.com/confirm/trace.aspx"

    'Get existing IE window open at page, if any
    
    Set IE = Get_IE_Window2(URL)
    If IE Is Nothing Then Set IE = New SHDocVw.InternetExplorer
    
    With IE
        .Visible = True
        SetForegroundWindow .hwnd
        .navigate URL
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
        Set HTMLdoc = .Document
    End With
    
    'Dropdown
    '< select name="_ctl0:lstType" onchange="javascript:setTimeout('__doPostBack(\'_ctl0$lstType\',\'\')', 0)" language="javascript" id="_ctl0_lstType">
    '        < option selected="selected" value="P">Pro Number< /option>
    '        < option value="B">Bill of Lading Number< /option>
    '        < option value="R">Customer Reference< /option>
    '        < option value="PO">Purchase Order< /option>
    '        < option value="PuN">Pickup Number< /option>
    '        < option value="CTIIRefNum">CT Reference Number< /option>
    '< /select>
    
    'Numbers input
    '< textarea name="_ctl0:traceNumbers" id="_ctl0_traceNumbers" class="textAreaTrace" style="height:80px;width:300px;">< /textarea>
    
    'Trace button
    '< input name="_ctl0:traceSubmit" id="_ctl0_traceSubmit" src="../images/btn_traceship.gif"
    '*******="javascript:WebForm_DoPostBackWithOptions(new WebForm_PostBackOptions("_ctl0:traceSubmit", "", true, "",
    '"", false, false))" language="javascript" type="image" border="0">
    
    'Hide IE window until page has updated, otherwise VBA incorrectly references a 2nd IE window (hidden) with no results
    
    IE.Visible = False
    
    With HTMLdoc
        .all("_ctl0_lstType").Value = "PuN"
        'Put dummy text in input box and click Trace to trigger page update
        .all("_ctl0:traceNumbers").innerText = "1"
        .all("_ctl0:traceSubmit").Click
        While .readyState <> "complete": DoEvents: Wend
        
        'Put trace numbers in input box and click Trace again
        .all("_ctl0:traceNumbers").innerText = traceNumbers
        .all("_ctl0:traceSubmit").Click
        While .readyState <> "complete": DoEvents: Wend
    End With
    
    'Show IE window again
    
    IE.Visible = True
    
    'Extract results
    
    Set resultsDiv = HTMLdoc.getElementById("_ctl0_pnlResultSet")
    Set resultsTable = resultsDiv.getElementsByTagName("TABLE")(0) 'main results table inside div
    Set infoTables = resultsTable.getElementsByTagName("TABLE")    'child tables
    
    For i = 0 To infoTables.Length - 5 Step 5
        Set infoTable = infoTables(i)
        
        PuNumber = infoTables(i + 2).Rows(2).Cells(3).innerText
    
        If InStr(1, infoTable.Rows(0).Cells(1).innerText, "Shipment was Spotted", vbTextCompare) > 0 Then
        
            result = infoTable.Rows(0).Cells(1).innerText
        
        Else
            
            Set infoTable = infoTables(i + 1)
            result = infoTable.Rows(0).Cells(1).innerText & "; " & _
                     infoTable.Rows(1).Cells(1).innerText & "; " & _
                     infoTable.Rows(2).Cells(1).innerText & "; "
            
        End If
    
        'Find this Pickup number in Excel cells and if found put result in adjacent cell
        
        PuNumberRow = Application.Match(PuNumber, pickupNumberCells, 0)
        If Not IsError(PuNumberRow) Then
            pickupNumberCells(PuNumberRow, 2).Value = result
        Else
            MsgBox "Pickup number " & PuNumber & " in results not found in cells " & pickupNumberCells.Address
        End If
        
    Next
    
    'Close IE window if necessary
    
    'IE.Quit
    Set IE = Nothing
    
    SetForegroundWindow Application.hwnd
    MsgBox "Done"
    
End Sub


Private Function Get_IE_Window2(URLorName As String) As InternetExplorer

    'Look for an IE browser window or tab already open at the (partial) URL or location name and, if found, return
    'that browser as an InternetExplorer object.  Otherwise return Nothing

    Dim Shell As Object
    Dim IE As InternetExplorer
    Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
    
    Set Shell = CreateObject("Shell.Application")
    
    i = 0
    Set Get_IE_Window2 = Nothing
    While i < Shell.Windows.count And Get_IE_Window2 Is Nothing
        Set IE = Shell.Windows.item(i)
        If Not IE Is Nothing Then
            'Debug.Print IE.LocationURL, IE.LocationName
            If TypeOf IE Is InternetExplorer And InStr(IE.LocationURL, "file://") <> 1 Then
                'Debug.Print i; IE.LocationName, IE.LocationURL
                If InStr(1, IE.LocationURL, URLorName, vbTextCompare) > 0 Or InStr(1, IE.LocationName, URLorName, vbTextCompare) > 0 Then
                    If Not IE.Busy Then Set Get_IE_Window2 = IE
                End If
            End If
        End If
        i = i + 1
    Wend
    
End Function
 

jalexmiller0

New Member
Joined
Nov 10, 2017
Messages
8
It works!! Seriously, you are incredible. I can't thank you enough for taking the time to work on this!


Now I have a couple questions. Is there any sort of limit to the amount of pick up numbers that the macro can search at a time? (like max 50 pickup numbers at a time?)

After some testing I found it occasionally doesn't pull back the results.
When I searched for these pickup numbers, for example:
PU-958-111307203285
PU-958-111307302567
PU-958-111307304061
PU-958-111307010764
PU-906-111307202868
PU-946-110607304322
PU-946-110607301852
PU-925-110307105066
PU-923-110807314268
PU-925-110810105172

<tbody>
</tbody>

The pickup number, PU-946-110607304322, doesn't return a result into excel. It leaves an empty cell next to it. It's the last one on the results page so I don't know if that has anything to do with it or not.

I also tried this set of pick up numbers:
PU-923-110607200115
PU-923-110707403174
PU-925-111415404987
PU-925-111508010386
PU-925-111508201554
PU-925-111507220659

<tbody>
</tbody>

And only the first one returned its results. I got a "Run-time error 424: Object required" on the following line:

Code:
PuNumber = infoTables(i + 2).Rows(2).Cells(3).innerText

I'm sorry to come back to you with more trouble because you have absolutely blown me away already. However, if you could take a look back at this, I would be even more grateful.

Again, thank you so much! I really appreciate your help.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,747

ADVERTISEMENT

Each shipment result occupies a set of 5 or 4 HTML tables. 5 tables if it has a 'heading' in bold, e.g. 145-4198298-0, or 4 if it doesn't.

Replace the For i = 0 .... Next block of code with this which increments the 'i' table index accordingly:

Code:
    i = 0
    While i < infoTables.Length - 1
        
        Set infoTable = infoTables(i)
        
        PuNumber = infoTables(i + 2).Rows(2).Cells(3).innerText
        Debug.Print PuNumber
    
        If InStr(1, infoTable.Rows(0).Cells(1).innerText, "Shipment was Spotted", vbTextCompare) > 0 Then
        
            result = infoTable.Rows(0).Cells(1).innerText
        
        Else
            
            Set infoTable = infoTables(i + 1)
            result = infoTable.Rows(0).Cells(1).innerText & "; " & _
                     infoTable.Rows(1).Cells(1).innerText & "; " & _
                     infoTable.Rows(2).Cells(1).innerText & "; "
            
        End If
    
        'Find this Pickup number in Excel cells and if found put result in adjacent cell
        
        PuNumberRow = Application.Match(PuNumber, pickupNumberCells, 0)
        If Not IsError(PuNumberRow) Then
            pickupNumberCells(PuNumberRow, 2).Value = result
        Else
            MsgBox "Pickup number " & PuNumber & " in results not found in cells " & pickupNumberCells.Address
        End If
        
        'Increment table index for next shipment, depending on whether this shipment has a 'heading' table in bold, e.g. 145-5545080-9
        
        If Trim(infoTables(i).innerText <> "") Then
            i = i + 5   'heading table
        Else
            i = i + 4   'no heading table
        End If
        
    Wend
Tested working with your 2 sets of pickup numbers above.

The macro extracts all shipments on the results page, however I don't know if the website has a limit on the maximum number of pickup numbers you can input on the search page or whether it puts the results on multiple pages, in which case the macro would only extract the results from the first page.
 

jalexmiller0

New Member
Joined
Nov 10, 2017
Messages
8
Holy cow!! This is so good! Thank you so much!!


Two more questions.

1. How can I make separate the results into columns from the ";"?

I tried text-to-columns in excel and told it to separate by semi-colon.
However, the city and state end up disappearing. I tried tinkering around in your code to make it work but I'm not sure what needs to change. I also tried recording a macro, in excel, of me using text-to-columns so I could just copy that onto the end of your code to automatically run it. However, it's still loosing the city and state and I'm just not sure why.


2. Is there anyway to have the macro run through 151 pick up number batches at a time? I found that central's website will search up to 151 pick up numbers at a time. The website keeps all the results on the same page. Just returns an error saying they couldn't trace the shipment at the 152nd pick up number.


You are incredible!! <3
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,747
I appreciate you having a go at modifying the code and recording a macro. Don't use text-to-columns though, as that is changing the data layout after the data has been scraped; better to put it in the required layout in the first place.

For the first change, look at the code where it assigns the 3 data parts to the result variable and puts it in 1 cell. Instead, use 3 lines to put the 3 data parts in 3 cells.

If you're still stuck I will look at these two and hopefully post the code updates later.
 

jalexmiller0

New Member
Joined
Nov 10, 2017
Messages
8
Thank you for the explanation. :cool:

I have figured it out! I also discovered that occasionally some PU numbers will have a result of "This shipment requires payment..." that threw off the If statement that checks for the "Shipment was spotted" cell. So I added an extra IF statement before the "Shipment was spotted" check in order to account for it. :D

This is very fun and I'm learning so much!

Here is my code if you'd like to double check anything. Or if someone is having a similar issue maybe this can be helpful to them.

Code:
'Set these references via Tools -> References in VBA editor:
'Microsoft Internet Controls
'Microsoft HTML Object Library




Option Explicit


'https://msdn.microsoft.com/en-us/library/office/gg264421.aspx
'64-Bit Visual Basic for Applications Overview


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    'New VBA version 7 compiler, therefore >= Office 2010
    'PtrSafe means function works in 32-bit and 64-bit Office
    'LongPtr type alias resolves to Long (32 bits) in 32-bit Office, or LongLong (64 bits) in 64-bit Office
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    'Old VBA version 6 or earlier compiler, therefore <= Office 2007
    Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If




Public Sub IE_Trace_Pickup_Numbers()
    
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim URL As String
    Dim pickupNumberCells As Range
    Dim traceSelect As HTMLSelectElement
    Dim traceTextArea As HTMLTextAreaElement
    Dim traceButton As HTMLInputButtonElement
    Dim traceNumbers As String
    Dim resultsDiv As HTMLDivElement
    Dim resultsTable As HTMLTable, infoTable As HTMLTable
    Dim infoTables As IHTMLElementCollection
    Dim i As Long
    Dim result As String
    Dim puTime As String
    Dim puLocation As String
    Dim PuNumber As String, PuNumberRow As Variant
    
    'Get pickup numbers from column A in 1st sheet starting at A2
    
    With Worksheets(1)
        Set pickupNumberCells = .Range("A2", .Cells(Rows.count, "A").End(xlUp))
    End With
    pickupNumberCells.Offset(, 1).ClearContents
    traceNumbers = Join(Application.Transpose(pickupNumberCells), vbNewLine)
    
    URL = "http://www.centraltransportint.com/confirm/trace.aspx"


    'Get existing IE window open at page, if any
    
    Set IE = Get_IE_Window2(URL)
    If IE Is Nothing Then Set IE = New SHDocVw.InternetExplorer
    
    With IE
        .Visible = True
        SetForegroundWindow .hwnd
        .navigate URL
        While .Busy Or .ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
        Set HTMLdoc = .Document
    End With
    
    'Dropdown
    '< select name="_ctl0:lstType" onchange="javascript:setTimeout('__doPostBack(\'_ctl0$lstType\',\'\')', 0)" language="javascript" id="_ctl0_lstType">
    '        < option selected="selected" value="P">Pro Number< /option>
    '        < option value="B">Bill of Lading Number< /option>
    '        < option value="R">Customer Reference< /option>
    '        < option value="PO">Purchase Order< /option>
    '        < option value="PuN">Pickup Number< /option>
    '        < option value="CTIIRefNum">CT Reference Number< /option>
    '< /select>
    
    'Numbers input
    '< textarea name="_ctl0:traceNumbers" id="_ctl0_traceNumbers" class="textAreaTrace" style="height:80px;width:300px;">< /textarea>
    
    'Trace button
    '< input name="_ctl0:traceSubmit" id="_ctl0_traceSubmit" src="../images/btn_traceship.gif"
    '*******="javascript:WebForm_DoPostBackWithOptions(new WebForm_PostBackOptions("_ctl0:traceSubmit", "", true, "",
    '"", false, false))" language="javascript" type="image" border="0">
    
    'Hide IE window until page has updated, otherwise VBA incorrectly references a 2nd IE window (hidden) with no results
    
    IE.Visible = False
    
    With HTMLdoc
        .all("_ctl0_lstType").Value = "PuN"
        'Put dummy text in input box and click Trace to trigger page update
        .all("_ctl0:traceNumbers").innerText = "1"
        .all("_ctl0:traceSubmit").Click
        While .ReadyState <> "complete": DoEvents: Wend
        
        'Put trace numbers in input box and click Trace again
        .all("_ctl0:traceNumbers").innerText = traceNumbers
        .all("_ctl0:traceSubmit").Click
        While .ReadyState <> "complete": DoEvents: Wend
    End With
    
    'Show IE window again
    
    IE.Visible = True
    
    'Extract results
    
    Set resultsDiv = HTMLdoc.getElementById("_ctl0_pnlResultSet")
    Set resultsTable = resultsDiv.getElementsByTagName("TABLE")(0) 'main results table inside div
    Set infoTables = resultsTable.getElementsByTagName("TABLE")    'child tables
    
    i = 0
    While i < infoTables.Length - 1
        
        Set infoTable = infoTables(i)
        
        PuNumber = infoTables(i + 2).Rows(2).Cells(3).innerText
 '       Debug.Print PuNumber
    
        If InStr(1, infoTable.Rows(0).Cells(0).innerText, "This shipment requires", vbTextCompare) > 0 Then
            
            result = infoTable.Rows(0).Cells(0).innerText
 '           Debug.Print result
            
        ElseIf InStr(1, infoTable.Rows(0).Cells(1).innerText, "Shipment was Spotted", vbTextCompare) > 0 Then
        
            result = infoTable.Rows(0).Cells(1).innerText
        
        Else
            
            Set infoTable = infoTables(i + 1)
            result = infoTable.Rows(0).Cells(1).innerText
            puTime = infoTable.Rows(1).Cells(1).innerText
            puLocation = infoTable.Rows(2).Cells(1).innerText
            
        End If
    
        'Find this Pickup number in Excel cells and if found put result in adjacent cell
        
        PuNumberRow = Application.Match(PuNumber, pickupNumberCells, 0)
        If Not IsError(PuNumberRow) Then
            pickupNumberCells(PuNumberRow, 2).Value = result
            pickupNumberCells(PuNumberRow, 3).Value = puTime
            pickupNumberCells(PuNumberRow, 4).Value = puLocation
        Else
            MsgBox "Pickup number " & PuNumber & " in results not found in cells " & pickupNumberCells.Address
        End If
        
        'Increment table index for next shipment, depending on whether this shipment has a 'heading' table in bold, e.g. 145-5545080-9
        
        If Trim(infoTables(i).innerText <> "") Then
            i = i + 5   'heading table
        Else
            i = i + 4   'no heading table
        End If
        
    Wend
    
        'Find this Pickup number in Excel cells and if found put result in adjacent cell
        
        PuNumberRow = Application.Match(PuNumber, pickupNumberCells, 0)
        If Not IsError(PuNumberRow) Then
            pickupNumberCells(PuNumberRow, 2).Value = result
            pickupNumberCells(PuNumberRow, 3).Value = puTime
            pickupNumberCells(PuNumberRow, 4).Value = puLocation
        Else
            MsgBox "Pickup number " & PuNumber & " in results not found in cells " & pickupNumberCells.Address
        End If
        
    
    'Close IE window if necessary
    
    'IE.Quit
    Set IE = Nothing
    
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    
    SetForegroundWindow Application.hwnd
    MsgBox "Done"
    
End Sub




Private Function Get_IE_Window2(URLorName As String) As InternetExplorer


    'Look for an IE browser window or tab already open at the (partial) URL or location name and, if found, return
    'that browser as an InternetExplorer object.  Otherwise return Nothing


    Dim Shell As Object
    Dim IE As InternetExplorer
    Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
    
    Set Shell = CreateObject("Shell.Application")
    
    i = 0
    Set Get_IE_Window2 = Nothing
    While i < Shell.Windows.count And Get_IE_Window2 Is Nothing
        Set IE = Shell.Windows.Item(i)
        If Not IE Is Nothing Then
            'Debug.Print IE.LocationURL, IE.LocationName
            If TypeOf IE Is InternetExplorer And InStr(IE.LocationURL, "file://") <> 1 Then
                'Debug.Print i; IE.LocationName, IE.LocationURL
                If InStr(1, IE.LocationURL, URLorName, vbTextCompare) > 0 Or InStr(1, IE.LocationName, URLorName, vbTextCompare) > 0 Then
                    If Not IE.Busy Then Set Get_IE_Window2 = IE
                End If
            End If
        End If
        i = i + 1
    Wend
    
End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,129,310
Messages
5,635,463
Members
416,858
Latest member
yelofneb

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
Top