Option Explicit
Sub GetContainerStatus()
Dim rngContID As Range 'the range containing the IDs
Dim rngCell As Range 'range to represent single cells
Dim rngMove As Range 'range of container numbers to move
Dim strURL As String 'Constructed URL
Dim qtData As QueryTable 'the query table
Dim LineCount As Integer 'counter for row number
Dim strDate As String 'holds move recent date
Dim rngTemp As Range 'temporary range used in date parsing
Dim Temp As Integer 'temporary counter used in date parsing
Dim strSmallID As String 'First 4 letters of ContainerID
Dim newSheet1 'Variable for sheet insertion
Dim newSheet2 'Variable for sheet insertion
Dim strResponse As String
strResponse = MsgBox("Are the web sites are working?", vbYesNo, "Web Query Readiness Check")
If strResponse = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'turn off screenupdating calculation to prevent screen flicker and speed-up code
Application.DisplayAlerts = False
Set newSheet1 = Worksheets.Add
Set newSheet2 = Worksheets.Add
newSheet1.Name = "Sandbox"
newSheet2.Name = "DataBash"
Application.DisplayAlerts = True
'insert scratch sheets
With Worksheets("Open PO status report")
Set rngMove = .Range(.Range("G7"), .Range("G65536").End(xlUp))
End With
With rngMove
.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("DataBash!A1"), unique:=True
End With
Set rngMove = Nothing
With Worksheets("DataBash")
Set rngContID = .Range(.Range("A2"), .Range("A65535").End(xlUp))
End With
'establish the range to work with
LineCount = 2
For Each rngCell In rngContID
'Loop through container numbers
strURL = ParseURL(rngCell.Value)
'establish the value in the cell and pass to the URL function
If Left(strURL, 4) <> "http" Then GoTo Continue
Set qtData = Worksheets("Sandbox").QueryTables.Add( _
Connection:="URL;" & strURL, _
Destination:=Worksheets("Sandbox").Range("A65536").End(xlUp).Offset(1))
'set a reference to the querytable
With qtData
.FieldNames = True
.BackgroundQuery = False
.TablesOnlyFromHTML = True
.Refresh
End With
Worksheets("Sandbox").Activate
strSmallID = Left(rngCell.Value, 4)
Select Case strSmallID
Case Is = "OOLU"
With ActiveSheet
Set rngTemp = .Range(.Range("B11"), .Range("B65536").End(xlUp))
End With
Temp = rngTemp.Rows.Count
strDate = Range("B" & 10 + Temp - 1 & "").Value
Case Is = "MOLU"
strDate = Range("E19").Value
End Select
If Right(strDate, 1) = "." Or strDate = "" Then
strDate = "No tracking for " & rngCell.Value
End If
Worksheets("DataBash").Select
Range("B" & LineCount).Value = strDate
Range("Sandbox!A1:BB3000").Delete
Continue:
Worksheets("DataBash").Select
If Range("B" & LineCount) = "" Then
Range("B" & LineCount).Value = strURL & rngCell.Value
End If
LineCount = LineCount + 1
strDate = 0
Next rngCell
Set rngTemp = Nothing
Set rngContID = Nothing
Set rngCell = Nothing
Set qtData = Nothing
'free memory
Call PlaceDates
Application.DisplayAlerts = False
With ActiveWorkbook
.Worksheets("Sandbox").Delete
.Worksheets("DataBash").Delete
End With
Application.DisplayAlerts = True
'delete scratch sheets
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'turn screenupdating and calculation back on
End Sub
'Select statement to get correct URL header
Function ParseURL(ContainerID As String) As String
Dim CID As String
CID = Left(ContainerID, 4)
'the abbreviated ContainerID
Select Case CID
Case Is = "YMLU"
ParseURL = "YMLU "
'ParseURL = _
"http://www.ymlu.com.tw/TRACK/ctconnect.asp?cntrno=" _
& ContainerID
Case Is = "OOLU"
ParseURL = _
"https://inetapp.oocl.com/ooclapp/cargo_tracking/cgo_cntr.asp?container_no=" _
& ContainerID
Case Is = "MAEU", "MAEC", "MAEX", "SEAU", "MAEX"
ParseURL = "Maersk Lines. "
Case Is = "MOLU"
ParseURL = "http://www.mitsuiosk.com/Request/owa/CTSearch?p_keyno=" _
& Left(ContainerID, 10) & "&p_action=Search"
Case Else
ParseURL = "No Tracking for "
End Select
End Function
Sub PlaceDates()
Dim rngDB1 As Range
Dim rngDB2 As Range
Dim rngOrigID As Range
Dim rngCellOID As Range
Dim Counter As Integer
Counter = 8
Application.ScreenUpdating = False
With Worksheets("DataBash")
Set rngDB1 = .Range(.Range("A2"), .Range("B65535").End(xlUp))
End With
With Worksheets("DataBash")
Set rngDB2 = .Range(.Range("B2"), .Range("B65535").End(xlUp))
End With
With Worksheets("Open PO status report")
Set rngOrigID = .Range(.Range("G8"), .Range("G65535").End(xlUp))
End With
For Each rngCellOID In rngOrigID
rngCellOID.Offset(0, 1).Value = "=index(DataBash!$A$2:$B$65535,match(G" & Counter & ",DataBash!$A$2:$A$65535,0),2)"
Counter = Counter + 1
Next rngCellOID
rngOrigID.Offset(0, 1).Copy
With rngOrigID.Offset(0, 1)
.PasteSpecial xlPasteValues
End With
Application.ScreenUpdating = True
End Sub