If you buy something from our facility, you will get a box with a shipping label on it. The two main numbers it will have are a FedEx tracking number and a carton number. For cartons that are not already in a manifested or invoiced status within our warehouse management system, it is necessary to check the FedEx website to determine if a carton has left our building. The statuses that I would be looking for on the FedEx website are "picked up", "in-transit", and "delivered".
The FedEx website categorizes tracking numbers in various sections depending on status. In June 2019, while looking at the html elements, there were 19 sections. To clarify, if you have a list of numbers you're looking up, the website takes the tracking numbers out of order, so as you're comparing your list with the website, you're scrolling up and down constantly trying to figure out which section the number is in. In most of my usage, there were only 2-3 sections used, but it still required constant up and down comparing back and forth. Ok, so you have the status on the website, you match that 10+ digit long tracking number with the one on your list, then you can highlight the associated carton number. The carton number that is in-transit is what we need, so we can process the carton number.
Another issue is the FedEx website only allows you to paste in 30 tracking numbers at time. So, if you're doing this manually for 1000 tracking numbers, you must somehow break up your list into 30 chunks at a time, then paste them into the website, do your looking back and forth comparing exercise, then do that 33 more times. That is going to take a long time, and due to nature of the process and length of the numbers, it will be very error-prone. You might even give up, because it’s so tedious.
I had a column of FedEx tracking numbers. In another column, I had a list of the associated carton numbers. My goal was to have a third column show the FedEx status. On that third column, I applied conditional formatting of green fill color to highlight text containing “picked up", "in-transit", "delivered". I could then filter on the green color, and I would have a list of carton numbers that had left the building. That was the end of my coding. From there, I could take that list and paste it into our warehouse management system to do the necessary processing.
The code will loop through the links, opening up Internet Explorer, Ctrl+A (selecting all), and Ctrl+C (copy), then return to shPastes(3. Pastes) and paste the results. Some filtering will occur, as to not grab all the unnecessary text.
Finally, in shStatus (4. Status), the filtered pastes will form into a table, and an index match will show the associated carton. A green filter on the status column will only show cartons in-transit, like so:
A few notes
This is my first time posting. I've been programming in VBA for less than a year. I'm a beginner. I don't know how to do arrays. Error handling is new for me. I have RubberDuck installed. This code is actually a re-write of my original, which was awful code, but it worked and saved me a ton of time at work.
I could have used XMLHTTPRequests to grab element id's, but there were too many possible status sections to mess around with, and if the site changed at all, the code might stop working.
I'm looking for a critique, so I can improve further. Thanks for your time.
'@Folder("FedEx_Tracking") Option Explicit '@Ignore ProcedureNotUsed Private Sub StartTrackingButton_Click() If DoSimpleChecks = "Not Ready" Then Exit Sub End If ProgressIndicatorForm.Show End Sub Private Function DoSimpleChecks() As String DoSimpleChecks = vbNullString '//Check if data has been pasted With shData If .Range("A2").Value = vbNullString Or .Range("B2").Value = vbNullString Then MsgBox "Please paste in the following data:" & vbNewLine & vbNewLine & "TRACKING number into A2" & vbNewLine & "CARTON number into B2", vbInformation, "Required Data" .Activate .Range("A2").Select DoSimpleChecks = "Not Ready" Else DoSimpleChecks = "Ready" End If End With End Function '@Ignore ProcedureNotUsed Private Sub ClearOldDataButton_Click() Call ClearSheetDataForNewUse End Sub Private Sub ClearSheetDataForNewUse() With shData .Columns("A:E").ClearContents .Range("A1").Value = "Paste Tracking" .Range("B1").Value = "Paste Carton" '//Move the cursor here for the user to begin pasting here .Range("A2").Select End With End Sub
'@Folder("FedEx_Tracking") Option Explicit Private Sub UserForm_Activate() Call TopMost End Sub
Attribute VB_Name = "m_fedex_tracking" '@Folder("FedEx_Tracking") Option Explicit Private Enum DataColumns [Paste Tracking] = 1 'A [Paste Carton] = 2 'B [Trimmed Tracking] = 3 'C [Concat Links] = 4 'D End Enum Private Enum READYSTATE READYSTATE_UNINITIALIZED = 0 READYSTATE_LOADING = 1 READYSTATE_LOADED = 2 READYSTATE_INTERACTIVE = 3 READYSTATE_COMPLETE = 4 End Enum Public Sub TopMost() On Error GoTo CleanFail Dim beginSeconds As Single beginSeconds = Timer() Call LudicrousMode(True) Call FormatColumnsAthruD Call TrimTextofTracking Call ConcatenateTrackingIntoLinks Call FilterForOnlyLinksAndPasteToSheetLinks Call LoopOpenIEandSelectAllCopyPaste Call SetEntireRangeOfResultingPastes Call CopyFilteredPastesToStatusesSheet Call CreateTableofStatuses Call CreateTableForTrackingCartonLookup Call IndexMatchToGetAssociatedCarton Call SetConditionalFormattingStatusColumnofStatusSheet Call FormatColumnWidthsOfStatusSheet Call FilterResultsOfStatusSheet Call TakeUserHereAtTheEnd CleanExit: Call LudicrousMode(False) Unload ProgressIndicatorForm Dim endSeconds As Single endSeconds = Timer() MsgBox "Time taken to complete:" & vbNewLine & endSeconds - beginSeconds & " seconds", vbInformation, vbNullString Exit Sub CleanFail: MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error" Resume CleanExit End Sub Private Sub LudicrousMode(ByVal Toggle As Boolean) 'Adjusts Excel settings for faster VBA processing 'Code from here: https://www.reddit.com/r/vba/comments/c7nkgo/speed_up_vba_code_with_ludicrousmode/ Application.ScreenUpdating = Not Toggle Application.EnableEvents = Not Toggle Application.DisplayAlerts = Not Toggle Application.EnableAnimations = Not Toggle Application.DisplayStatusBar = Not Toggle Application.Calculation = IIf(Toggle, xlCalculationManual, xlCalculationAutomatic) End Sub Private Sub FormatColumnsAthruD() Const HEADER_ROW_NUM As Long = 1 '//Format columns A:C as text, not D, because I might want it to be a clickable link in the future shData.Columns("A:C").NumberFormat = "@" '//If there is old generated data, clear it shData.Columns("C:D").ClearContents 'TODO: Take a look whether using private enum for columns is even necessary for this project scope with such few headers _ it was mainly done this way because I had never used private enums before. '//Re-write the column headers of the cleared columns shData.Cells(HEADER_ROW_NUM, DataColumns.[Trimmed Tracking]).Value = "Trimmed Tracking" shData.Cells(HEADER_ROW_NUM, DataColumns.[Concat Links]).Value = "Concat Links" End Sub Private Function GetLastDataRow(ByVal xlSheet As Worksheet, Optional ByVal columnLetter As String = "A") As Long 'Function obtained from here: https://codereview.stackexchange.com/questions/43290/importing-data-from-an-external-excel-sheet 'RubberDuck inspection quacks: "Argument with incompatible object type" every time the function is used, but no errors are present when running the code. '//a worksheet's codename is passed to xlSheet; GetLastDataRow = xlSheet.Range(columnLetter & xlSheet.Rows.Count).End(xlUp).Row End Function Private Sub TrimTextofTracking() Dim lastPasteTrackingRow As Long lastPasteTrackingRow = GetLastDataRow(shData, "A") '//Use trim function to remove leading or trailing spaces, otherwise it will mess up lookups; _ write to a new column Dim i As Long For i = 2 To lastPasteTrackingRow With shData .Cells(i, DataColumns.[Trimmed Tracking]).Value = WorksheetFunction.Trim(.Cells(i, DataColumns.[Paste Tracking])) End With Next i 'shData.Columns(DataColumns.[Trimmed Tracking]).EntireColumn.AutoFit End Sub Private Sub ConcatenateTrackingIntoLinks() 'Const OLD_PREFIX_FOR_FEDEX_LINK As String = "https://www.fedex.com/apps/fedextrack/index.html?tracknumbers=" Const PREFIX_FOR_FEDEX_LINK As String = "https://www.fedex.com/apps/fedextrack/?action=track&trackingnumber=" Const SUFFIX_FOR_FEDEX_LINK As String = "&cntry_code=us&locale=en_US" '//This does not include the 1st tracking number at the start of each range. _ If included, it would equal 30, which is the max number of tracking numbers that can be concatenated into a link, set by FedEx.com Const ADD_TO_FIRST_STRING As Long = 29 '//First tracking number of link2 is 30 numbers after the first tracking number of link1 'Link1inD2 = C2:C31 'Link2inD32 = C32:C61 Const ROWS_BETWEEN_GENERATED_LINKS = 30 Dim lastTrimmedRow As Long lastTrimmedRow = GetLastDataRow(shData, "C") '//Ideally 30 Tracking numbers concatenated to form a link, then for example:& _ tracking1-30 = link1; tracking 31-60 = link 2; etc. Dim i As Long For i = 2 To lastTrimmedRow Step ROWS_BETWEEN_GENERATED_LINKS shData.Cells(i, DataColumns.[Concat Links]).Value = PREFIX_FOR_FEDEX_LINK & _ concatRange(shData.Range("C" & i & ":C" & i + ADD_TO_FIRST_STRING), ",") & _ SUFFIX_FOR_FEDEX_LINK Next i End Sub Public Function concatRange(ByVal myRange As Range, ByVal mySeperator As String) As String 'Code came from some website Dim cell As Range Dim currentRange As String Dim r As String currentRange = vbNullString For Each cell In myRange If cell.Value <> vbNullString Then r = cell.Value & mySeperator currentRange = currentRange & r End If Next cell currentRange = Left$(currentRange, Len(currentRange) - Len(mySeperator)) concatRange = currentRange End Function Private Sub FilterForOnlyLinksAndPasteToSheetLinks() shLinks.Cells.ClearContents '//Filter column, no blanks shData.Range("D1").AutoFilter Field:=4, criteria1:="<>", Operator:=xlFilterValues '//Get range & copy Dim lastConcatLinksRow As Long lastConcatLinksRow = GetLastDataRow(shData, "A") shData.Range("D2", "D" & lastConcatLinksRow).Copy '//Paste selection to new sheet shLinks.Range("C1").PasteSpecial '//Remove filter shData.Range("D1").AutoFilter '//Exit out of cut/copy mode Application.CutCopyMode = False End Sub Private Sub ClearAndFormatSheetPastesAsText() With shPastes .Cells.ClearContents .Cells.NumberFormat = "@" End With End Sub Private Sub LoopOpenIEandSelectAllCopyPaste() Call ClearAndFormatSheetPastesAsText With shPastes '//Set the first place to begin pasting; This has to be here for the rest of the sub to work. .Activate .Range("A1").Select End With Dim lastLinkRow As Long lastLinkRow = GetLastDataRow(shLinks, "C") Dim IEbrowser As Object Set IEbrowser = CreateObject("InternetExplorer.Application") Dim linkRow As Long For linkRow = 1 To lastLinkRow With IEbrowser .Visible = True .Navigate (shLinks.Cells(linkRow, "C")) '//Wait for page to finish loading Do While .busy Or .READYSTATE <> READYSTATE.READYSTATE_COMPLETE DoEvents Loop '//this additional wait is necessary on FedEx website to ensure page is fully loaded Application.Wait (Now + TimeValue("00:00:04")) '// SelectAll (Ctrl+A) .ExecWB 17, 0 Application.Wait (Now + TimeValue("00:00:01")) '// Copy selection (Ctrl+C) .ExecWB 12, 2 End With '//Paste as Match destination formatting & _ FormatHTML, but with no HTMLFormatting is absolutely necessary for pasting from FedEx tracking website & _ because it keeps necessary table formatting. Tracking no., status, etc. are each kept in same row but separate columns, & _ which makes it possible to filter the results. Pasting as text or values does not work! With shPastes .PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True '//Set starting point for next paste .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Select End With '//'https://www.excel-easy.com/vba/examples/progress-indicator.html _ if there are 10 links, it will show 10% complete after the 1st link Dim percentComplete As Single percentComplete = (linkRow / lastLinkRow) * 100 progress percentComplete Next linkRow IEbrowser.Quit Set IEbrowser = Nothing End Sub Private Sub SetEntireRangeOfResultingPastes() '//Find position of last cell Dim lastPastesRow As Long lastPastesRow = GetLastDataRow(shPastes, "A") 'TODO: redo this particular lastColumn variable to get rid of ActiveCell Dim lastColumn As Long lastColumn = ActiveCell.SpecialCells(xlLastCell).column '//Set range Dim EntireRangeOfPastes As Range Set EntireRangeOfPastes = shPastes.Range("A1", shPastes.Cells(lastPastesRow, lastColumn)) '//Filter range on Column A ascending (A to Z), so the tracking numbers are at the top EntireRangeOfPastes.AutoFilter EntireRangeOfPastes.Sort key1:=shPastes.Range("A1"), order1:=xlAscending, Header:=xlNo '//Remove duplicates on Column A shPastes.Range("A1", shPastes.Cells(lastPastesRow, lastColumn)).RemoveDuplicates Columns:=1, Header:=xlNo End Sub Private Sub CopyFilteredPastesToStatusesSheet() '//Find position of last cell Dim lastPastesRow As Long lastPastesRow = GetLastDataRow(shPastes, "A") 'TODO: redo this particular lastColumn variable to get rid of ActiveCell Dim lastColumn As Long lastColumn = ActiveCell.SpecialCells(xlLastCell).column '//Set range Dim filteredPastes As Range Set filteredPastes = shPastes.Range("A1", shPastes.Cells(lastPastesRow, lastColumn)) '//Clear entire sheet, where I will be pasting to, along with clearing any conditional formatting With shStatus .Cells.ClearContents .Cells.FormatConditions.Delete .Columns.Range("B:B", "B:B").NumberFormat = "@" End With '//Copy & Paste filteredPastes.Copy With shStatus .Range("B1").PasteSpecial .Range("A1").Value = "Carton" End With End Sub Private Sub CreateTableofStatuses() '//Since I have a lookup in column Z (column 26), & _ Set this first table to have a max of 10 columns ending in column J, so there isn't a possiblity of a table overlap error Const FIRST_TABLE_LAST_COLUMN As Long = 10 '//Get position of lastTrackingRow Dim lastTrackingRow As Long lastTrackingRow = GetLastDataRow(shStatus, "B") '//Create Table shStatus.ListObjects.Add(xlSrcRange, shStatus.Range("A1", shStatus.Cells(lastTrackingRow, FIRST_TABLE_LAST_COLUMN)), , xlYes).Name = "tbl_FedEx" With shStatus '// Write/Overwrite Headers for first few columns in case there are no cartons with status found .Range("A1").Value = "Carton" .Range("B1").Value = "Tracking No. or Nickname" .Range("C1").Value = "Status" .Range("D1").Value = "Scheduled Delivery Date" .Range("E1").Value = "Ship Date" End With End Sub Private Sub CreateTableForTrackingCartonLookup() 'Copying the range from shData to shStatus seems unnecessary, but if I want, I can make a copy of shStatus and rename it or move it to another workbook for historical and sharing purposes. _ Sharing a single worksheet with all the info on it is easiest. '//Set range of first four columns Dim trackingCartonLookup As Range Set trackingCartonLookup = shData.Range("A1").CurrentRegion '//Copy & paste range far enough from the first table trackingCartonLookup.Copy shStatus.Range("Z1").PasteSpecial '//Find position of last cell in range Dim lastRow As Long lastRow = shStatus.Range("Z1").CurrentRegion.Rows.Count Dim lastColumn As Long lastColumn = shStatus.Cells(1, shStatus.Columns.Count).End(xlToLeft).column '//Create Table shStatus.ListObjects.Add(xlSrcRange, shStatus.Range("Z1", shStatus.Cells(lastRow, lastColumn)), , xlYes).Name = "tbl_trackingCarton" End Sub Private Sub IndexMatchToGetAssociatedCarton() Const MINIMUM_TABLE_ROWS As Long = 2 Const DOUBLE_QUOTE As String = """" '//To display a message upon N/A, replace vbNullString with "text" (including the " " around text) Const EXPLANATION_IF_NA As String = DOUBLE_QUOTE & vbNullString & DOUBLE_QUOTE On Error GoTo CleanFail With shStatus '//Index Match .Range("A2").Value = "=IFNA(INDEX(tbl_trackingCarton,MATCH([@[Tracking No. or Nickname]],tbl_trackingCarton[Trimmed Tracking],0),2)," & EXPLANATION_IF_NA & ")" Continue: '//To prevent error, Autofill down--only if the table has enough rows If .Range("A1").CurrentRegion.Rows.Count > MINIMUM_TABLE_ROWS Then .Range("A2").AutoFill Destination:=.Range("tbl_FedEx[Carton]") End If End With '@Ignore LineLabelNotUsed CleanExit: Exit Sub CleanFail: If Err.Number = 1004 Then Err.Clear '// Win 7 32-bit, Excel 2010 32-bit VBA 6.5 gave this error until I changed the formula to this shStatus.Range("A2").Value = "=INDEX(tbl_trackingCarton,MATCH(tbl_FedEx[[#This Row],[Tracking No. or Nickname]],tbl_trackingCarton[Trimmed Tracking],0),2)" Else MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error" Exit Sub End If GoTo Continue End Sub Private Sub SetConditionalFormattingStatusColumnofStatusSheet() Const COLOR_GRANNY_APPLE As Long = 13561798 'Same as the Style "Good" fill color Dim statusColumn As Range Set statusColumn = shStatus.Range("tbl_FedEx[Status]") With statusColumn.FormatConditions.Add(xlTextString, TextOperator:=xlContains, String:="Picked Up") With .Interior .PatternColorIndex = xlColorIndexNone .Color = COLOR_GRANNY_APPLE End With End With With statusColumn.FormatConditions.Add(xlTextString, TextOperator:=xlContains, String:="In transit") With .Interior .PatternColorIndex = xlColorIndexNone .Color = COLOR_GRANNY_APPLE End With End With With statusColumn.FormatConditions.Add(xlTextString, TextOperator:=xlContains, String:="Delivered") With .Interior .PatternColorIndex = xlColorIndexNone .Color = COLOR_GRANNY_APPLE End With End With End Sub Private Sub FormatColumnWidthsOfStatusSheet() With shStatus '//Resize columns 'Carton', 'Tracking', & 'Status' .Columns("A:A").ColumnWidth = 26 .Columns("B:B").ColumnWidth = 26 .Columns("C:C").ColumnWidth = 26 '//Autofit 'Paste Tracking', 'Paste Carton', & 'Trimmed Tracking' columns .Range("Z:Z", "AB:AB").EntireColumn.AutoFit End With End Sub Private Sub FilterResultsOfStatusSheet() Const COLOR_GRANNY_APPLE As Long = 13561798 With shStatus '//Filter out the blanks in column 1 - disabled for now '.ListObjects("tbl_FedEx").Range.AutoFilter Field:=1, Criteria1:="<>" '//Filter on the green color .ListObjects("tbl_FedEx").Range.AutoFilter Field:=3, criteria1:=COLOR_GRANNY_APPLE, Operator:=xlFilterCellColor End With End Sub Private Sub TakeUserHereAtTheEnd() With shStatus '//Navigate the user here to view the results .Activate .Range("C1").Select End With End Sub Private Sub progress(ByVal percentComplete As Single) 'Progress indicator code from here: https://www.excel-easy.com/vba/examples/progress-indicator.html ProgressIndicatorForm.Text.Caption = percentComplete & "% Completed" ProgressIndicatorForm.Bar.Width = percentComplete * 2 DoEvents End Sub