Codebin.net

New Paste Browse

Option Explicit

Sub OTD_FINAL_PROCESSOR()

Dim fp As Object
    Dim folderPath As String
    Dim fso As Object
    Dim folderObj As Object
    Dim fileObj As Object
    Dim fileName As String
    Dim fullPath As String
    Dim fileExtension As String

Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim candidateWS As Worksheet
    Dim masterWS As Worksheet
    Dim summaryWS As Worksheet
    Dim carrierWS As Worksheet
    Dim existingWS As Worksheet
    Dim ws As Worksheet

Dim headerRow As Long
    Dim firstDataRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim masterNextRow As Long
    Dim summaryNextRow As Long

Dim carrierCol As Long
    Dim shipmentDateCol As Long
    Dim agreedTTCol As Long
    Dim actualTTCol As Long
    Dim varianceCol As Long
    Dim reasonLateCol As Long

Dim pickupDateCol As Long
    Dim departureDateCol As Long
    Dim arrivalPortDateCol As Long
    Dim arrivalConsigneeDateCol As Long

Dim rowNumber As Long
    Dim sheetNumber As Long
    Dim searchRow As Long
    Dim searchCol As Long

Dim carrierName As String
    Dim carrierSheetName As String
    Dim baseSheetName As String
    Dim suffixNumber As Long

Dim shipmentCount As Long
    Dim missingAgreedTT As Long
    Dim missingActualTT As Long
    Dim missingReasonLate As Long
    Dim dateFormatIssue As Long
    Dim totalIssues As Long

Dim dateColumns As Variant
    Dim dateColumn As Variant
    Dim visibleDate As String
    Dim dateOnly As String

Dim varianceValue As Variant
    Dim reasonValue As Variant
    Dim reasonText As String

Dim shipmentDateValue As Date
    Dim validShipmentDate As Boolean
    Dim validShipmentRow As Boolean
    Dim dataSheetFound As Boolean

Dim lastUsedCell As Range
    Dim lastHeaderCell As Range

On Error GoTo ProcessorError

Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.CutCopyMode = False

Set fp = Application.FileDialog(4)

fp.Title = "Select the folder containing the OTD carrier reports"
    fp.AllowMultiSelect = False

If fp.Show <> -1 Then
        GoTo SafeExit
    End If

folderPath = fp.SelectedItems(1)

Set masterWS = Nothing
    Set summaryWS = Nothing

On Error Resume Next
    Set masterWS = ThisWorkbook.Worksheets("Master Report")
    Set summaryWS = ThisWorkbook.Worksheets("Carrier Summary")
    On Error GoTo ProcessorError

If masterWS Is Nothing Then
        Set masterWS = ThisWorkbook.Worksheets.Add
        masterWS.Name = "Master Report"
    End If

If summaryWS Is Nothing Then
        Set summaryWS = ThisWorkbook.Worksheets.Add(After:=masterWS)
        summaryWS.Name = "Carrier Summary"
    End If

For sheetNumber = ThisWorkbook.Worksheets.Count To 1 Step -1

Set ws = ThisWorkbook.Worksheets(sheetNumber)

If LCase(ws.Name) <> "master report" Then
    If LCase(ws.Name) <> "carrier summary" Then
        If LCase(ws.Name) <> "carrier follow up" Then
            If LCase(ws.Name) <> "reason mapping" Then
                If LCase(ws.Name) <> "reason analysis" Then
                    If LCase(ws.Name) <> "reason category analysis" Then
                        If LCase(ws.Name) <> "read me" Then
                            If LCase(ws.Name) <> "instructions" Then
                                ws.Delete
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
End If

Next sheetNumber

masterWS.Cells.Clear
    summaryWS.Cells.Clear

masterNextRow = 1
    summaryNextRow = 2

summaryWS.Cells(1, 1).Value = "Carrier"
    summaryWS.Cells(1, 2).Value = "Shipments"
    summaryWS.Cells(1, 3).Value = "Missing Agreed TT"
    summaryWS.Cells(1, 4).Value = "Missing Actual TT"
    summaryWS.Cells(1, 5).Value = "Missing Reason For Late"
    summaryWS.Cells(1, 6).Value = "Date Format Issue"
    summaryWS.Cells(1, 7).Value = "Total Issues"

Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderObj = fso.GetFolder(folderPath)

For Each fileObj In folderObj.Files

fileName = CStr(fileObj.Name)
        fileExtension = LCase(CStr(fso.GetExtensionName(fileName)))

If Left(fileName, 2) <> "~$" Then

If fileName <> ThisWorkbook.Name Then

If fileExtension = "xlsx" Or _
                   fileExtension = "xlsm" Or _
                   fileExtension = "xls" Then

fullPath = CStr(fileObj.Path)

Set sourceWB = Workbooks.Open( _
                        fileName:=fullPath, _
                        ReadOnly:=True, _
                        UpdateLinks:=False)

Set sourceWS = Nothing
                    dataSheetFound = False
                    headerRow = 0

For Each candidateWS In sourceWB.Worksheets

For searchRow = 1 To 20

For searchCol = 1 To 30

If Not IsError(candidateWS.Cells(searchRow, searchCol).Value) Then

If LCase(Trim(CStr( _
                                        candidateWS.Cells(searchRow, searchCol).Value))) = _
                                        "freight forwarder" Then

Set sourceWS = candidateWS
                                        headerRow = searchRow
                                        dataSheetFound = True
                                        Exit For

End If

Next searchCol

If dataSheetFound = True Then Exit For

Next searchRow

If dataSheetFound = True Then Exit For

Next candidateWS

If dataSheetFound = False Then

sourceWB.Close SaveChanges:=False
                        Set sourceWB = Nothing

Else

carrierCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Freight Forwarder"))

shipmentDateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Shipment Date"))

agreedTTCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Agreed Transit Time"))

actualTTCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Actual Transit Time"))

varianceCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array( _
                                "Actual Transit Time v Agreed Transit Time", _
                                "Actual Transit Time vs Agreed Transit Time"))

reasonLateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Reason for Late"))

pickupDateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array( _
                                "Actual Pick-Up Date", _
                                "Actual Pick Up Date"))

departureDateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Actual Departure from Origin Port"))

arrivalPortDateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Actual Arrival to Destination Port"))

arrivalConsigneeDateCol = OTD_FindHeaderColumn( _
                            sourceWS, headerRow, _
                            Array("Actual Arrival to Consignee"))

firstDataRow = headerRow + 1

carrierName = ""

If carrierCol > 0 Then

If Not IsError(sourceWS.Cells(firstDataRow, carrierCol).Value) Then
                                carrierName = Trim(CStr( _
                                    sourceWS.Cells(firstDataRow, carrierCol).Value))
                            End If

End If

If carrierName = "" Then

carrierName = fso.GetBaseName(fileName)

carrierName = Replace( _
                                carrierName, "OTD-", "", _
                                1, -1, vbTextCompare)

carrierName = Replace( _
                                carrierName, "OTD_", "", _
                                1, -1, vbTextCompare)

End If

carrierSheetName = carrierName

carrierSheetName = Replace(carrierSheetName, "/", "-")
                        carrierSheetName = Replace(carrierSheetName, "\", "-")
                        carrierSheetName = Replace(carrierSheetName, ":", "-")
                        carrierSheetName = Replace(carrierSheetName, Chr(42), "-")
                        carrierSheetName = Replace(carrierSheetName, "?", "-")
                        carrierSheetName = Replace(carrierSheetName, "[", "-")
                        carrierSheetName = Replace(carrierSheetName, "]", "-")

If Len(carrierSheetName) > 31 Then
                            carrierSheetName = Left(carrierSheetName, 31)
                        End If

baseSheetName = carrierSheetName
                        suffixNumber = 1

Do
Do

Set existingWS = Nothing

On Error Resume Next
    Set existingWS = ThisWorkbook.Worksheets(carrierSheetName)
    On Error GoTo ProcessorError

If existingWS Is Nothing Then Exit Do

suffixNumber = suffixNumber + 1

carrierSheetName = _
        Left(baseSheetName, 27) & _
        "_" & CStr(suffixNumber)

Loop
                            
                        Loop

Set carrierWS = ThisWorkbook.Worksheets.Add( _
                            After:=ThisWorkbook.Worksheets( _
                                ThisWorkbook.Worksheets.Count))

carrierWS.Name = carrierSheetName

Set lastUsedCell = sourceWS.Cells.Find( _
                            What:=Chr(42), _
                            After:=sourceWS.Cells(1, 1), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)

Set lastHeaderCell = sourceWS.Cells.Find( _
                            What:=Chr(42), _
                            After:=sourceWS.Cells(1, 1), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)

If lastUsedCell Is Nothing Then

sourceWB.Close SaveChanges:=False
                            Set sourceWB = Nothing

ElseIf lastHeaderCell Is Nothing Then

sourceWB.Close SaveChanges:=False
                            Set sourceWB = Nothing

Else

lastRow = lastUsedCell.Row
                            lastCol = lastHeaderCell.Column

sourceWS.Range( _
                                sourceWS.Cells(headerRow, 1), _
                                sourceWS.Cells(lastRow, lastCol)).Copy

carrierWS.Cells(1, 1).PasteSpecial _
                                Paste:=xlPasteValuesAndNumberFormats

If masterNextRow = 1 Then

sourceWS.Range( _
                                    sourceWS.Cells(headerRow, 1), _
                                    sourceWS.Cells(headerRow, lastCol)).Copy

masterWS.Cells(1, 1).PasteSpecial _
                                    Paste:=xlPasteValuesAndNumberFormats

masterNextRow = 2

End If

If lastRow >= firstDataRow Then

sourceWS.Range( _
                                    sourceWS.Cells(firstDataRow, 1), _
                                    sourceWS.Cells(lastRow, lastCol)).Copy

masterWS.Cells(masterNextRow, 1).PasteSpecial _
                                    Paste:=xlPasteValuesAndNumberFormats

masterNextRow = masterWS.Cells( _
                                    masterWS.Rows.Count, 1).End(xlUp).Row + 1

End If

shipmentCount = 0
                            missingAgreedTT = 0
                            missingActualTT = 0
                            missingReasonLate = 0
                            dateFormatIssue = 0

dateColumns = Array( _
                                shipmentDateCol, _
                                pickupDateCol, _
                                departureDateCol, _
                                arrivalPortDateCol, _
                                arrivalConsigneeDateCol)

For rowNumber = firstDataRow To lastRow

validShipmentRow = False

If sourceWS.Rows(rowNumber).Hidden = False Then

If carrierCol > 0 Then

If Trim(CStr( _
                                            sourceWS.Cells( _
                                                rowNumber, carrierCol).Text)) <> "" Then

validShipmentRow = True

End If

If validShipmentRow = True Then

shipmentCount = shipmentCount + 1

If agreedTTCol > 0 Then

If Trim(CStr( _
                                            sourceWS.Cells( _
                                                rowNumber, agreedTTCol).Text)) = "" Then

missingAgreedTT = _
                                                missingAgreedTT + 1

End If

If actualTTCol > 0 Then

If Trim(CStr( _
                                            sourceWS.Cells( _
                                                rowNumber, actualTTCol).Text)) = "" Then

missingActualTT = _
                                                missingActualTT + 1

End If

For Each dateColumn In dateColumns

If CLng(dateColumn) > 0 Then

visibleDate = Trim(CStr( _
                                                sourceWS.Cells( _
                                                    rowNumber, CLng(dateColumn)).Text))

visibleDate = Replace( _
                                                visibleDate, Chr(160), " ")

visibleDate = Replace( _
                                                visibleDate, vbTab, " ")

visibleDate = Trim(visibleDate)

If visibleDate <> "" Then

dateOnly = visibleDate

If InStr(1, dateOnly, " ") > 0 Then
                                                    dateOnly = Split(dateOnly, " ")(0)
                                                End If

If OTD_DateFormatValid(dateOnly) = False Then
                                                    dateFormatIssue = 1
                                                End If

End If

Next dateColumn

validShipmentDate = False

If shipmentDateCol > 0 Then

validShipmentDate = OTD_GetShipmentDate( _
                                            sourceWS.Cells( _
                                                rowNumber, shipmentDateCol), _
                                            shipmentDateValue)

End If

If validShipmentDate = True Then

If shipmentDateValue >= DateSerial(2026, 6, 1) Then

If varianceCol > 0 Then

If reasonLateCol > 0 Then

varianceValue = sourceWS.Cells( _
                                                        rowNumber, varianceCol).Value2

reasonValue = sourceWS.Cells( _
                                                        rowNumber, reasonLateCol).Value2

If IsError(reasonValue) Then
                                                        reasonText = ""
                                                    Else
                                                        reasonText = Trim(CStr(reasonValue))
                                                    End If

If Not IsError(varianceValue) Then

If IsNumeric(varianceValue) Then

If CDbl(varianceValue) > 0 Then

If reasonText = "" Then

missingReasonLate = _
                                                                        missingReasonLate + 1

End If

Next rowNumber

totalIssues = _
                                missingAgreedTT + _
                                missingActualTT + _
                                missingReasonLate + _
                                dateFormatIssue

summaryWS.Cells( _
                                summaryNextRow, 1).Value = carrierName

summaryWS.Cells( _
                                summaryNextRow, 2).Value = shipmentCount

summaryWS.Cells( _
                                summaryNextRow, 3).Value = missingAgreedTT

summaryWS.Cells( _
                                summaryNextRow, 4).Value = missingActualTT

summaryWS.Cells( _
                                summaryNextRow, 5).Value = missingReasonLate

If dateFormatIssue = 1 Then
                                summaryWS.Cells(summaryNextRow, 6).Value = "Yes"
                            Else
                                summaryWS.Cells(summaryNextRow, 6).Value = "No"
                            End If

summaryWS.Cells( _
                                summaryNextRow, 7).Value = totalIssues

With carrierWS.UsedRange

.Interior.Pattern = xlNone
                                .Font.Name = "Calibri"
                                .Font.Size = 11
                                .Font.Color = RGB(0, 0, 0)

End With

With carrierWS.Rows(1)

.Font.Bold = True
                                .Font.Color = RGB(255, 255, 255)
                                .Interior.Color = RGB(31, 78, 121)

End With

carrierWS.Columns.AutoFit

summaryNextRow = summaryNextRow + 1

sourceWB.Close SaveChanges:=False
                            Set sourceWB = Nothing

End If

Next fileObj

With masterWS.UsedRange

.Interior.Pattern = xlNone
        .Font.Name = "Calibri"
        .Font.Size = 11
        .Font.Color = RGB(0, 0, 0)

End With

With masterWS.Rows(1)

.Font.Bold = True
        .Font.Color = RGB(255, 255, 255)
        .Interior.Color = RGB(31, 78, 121)

End With

With summaryWS.UsedRange

.Interior.Pattern = xlNone
        .Font.Name = "Calibri"
        .Font.Size = 11
        .Font.Color = RGB(0, 0, 0)

End With

With summaryWS.Rows(1)

.Font.Bold = True
        .Font.Color = RGB(255, 255, 255)
        .Interior.Color = RGB(31, 78, 121)

End With

masterWS.Columns.AutoFit
    summaryWS.Columns.AutoFit

MsgBox "OTD Processor Complete"

SafeExit:

Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True

Exit Sub

ProcessorError:

MsgBox _
        "The processor stopped while reading:" & vbCrLf & _
        fileName & vbCrLf & vbCrLf & _
        "Error " & Err.Number & ": " & Err.Description

If Not sourceWB Is Nothing Then
        sourceWB.Close SaveChanges:=False
    End If

Resume SafeExit

End Sub

Private Function OTD_FindHeaderColumn( _
    ByVal targetWS As Worksheet, _
    ByVal targetHeaderRow As Long, _
    ByVal possibleHeaders As Variant) As Long

Dim columnNumber As Long
    Dim headerOption As Variant
    Dim headerText As String
    Dim finalColumn As Long

OTD_FindHeaderColumn = 0

finalColumn = targetWS.Cells( _
        targetHeaderRow, _
        targetWS.Columns.Count).End(xlToLeft).Column

For columnNumber = 1 To finalColumn

If Not IsError( _
            targetWS.Cells( _
                targetHeaderRow, columnNumber).Value) Then

headerText = LCase(Trim(CStr( _
                targetWS.Cells( _
                    targetHeaderRow, columnNumber).Value)))

For Each headerOption In possibleHeaders

If headerText = _
                    LCase(Trim(CStr(headerOption))) Then

OTD_FindHeaderColumn = columnNumber
                    Exit Function

End If

Next headerOption

End If

Next columnNumber

End Function

Private Function OTD_DateFormatValid( _
    ByVal dateText As String) As Boolean

Dim dateParts As Variant
    Dim monthPart As Long
    Dim dayPart As Long
    Dim yearPart As Long
    Dim testDate As Date

OTD_DateFormatValid = False

dateText = Trim(dateText)

If dateText = "" Then

OTD_DateFormatValid = True
        Exit Function

End If

If InStr(1, dateText, "/") = 0 Then
        Exit Function
    End If

dateParts = Split(dateText, "/")

If UBound(dateParts) <> 2 Then
        Exit Function
    End If

If Not IsNumeric(dateParts(0)) Then
        Exit Function
    End If

If Not IsNumeric(dateParts(1)) Then
        Exit Function
    End If

If Not IsNumeric(dateParts(2)) Then
        Exit Function
    End If

monthPart = CLng(dateParts(0))
    dayPart = CLng(dateParts(1))
    yearPart = CLng(dateParts(2))

If monthPart < 1 Or monthPart > 12 Then
        Exit Function
    End If

If dayPart < 1 Or dayPart > 31 Then
        Exit Function
    End If

If yearPart < 1900 Or yearPart > 2100 Then
        Exit Function
    End If

On Error GoTo InvalidDate

testDate = DateSerial(yearPart, monthPart, dayPart)

If Month(testDate) <> monthPart Then
        Exit Function
    End If

If Day(testDate) <> dayPart Then
        Exit Function
    End If

If Year(testDate) <> yearPart Then
        Exit Function
    End If

OTD_DateFormatValid = True
    Exit Function

InvalidDate:

OTD_DateFormatValid = False

End Function

Private Function OTD_GetShipmentDate( _
    ByVal dateCell As Range, _
    ByRef parsedDate As Date) As Boolean

Dim rawValue As Variant
    Dim displayedText As String
    Dim dateOnly As String
    Dim dateParts As Variant

Dim monthPart As Long
    Dim dayPart As Long
    Dim yearPart As Long

OTD_GetShipmentDate = False

rawValue = dateCell.Value2

If IsError(rawValue) Then
        Exit Function
    End If

If IsNumeric(rawValue) Then

If CDbl(rawValue) > 0 Then

On Error GoTo InvalidShipmentDate

parsedDate = CDate(rawValue)
            parsedDate = DateSerial( _
                Year(parsedDate), _
                Month(parsedDate), _
                Day(parsedDate))

OTD_GetShipmentDate = True
            Exit Function

End If

displayedText = Trim(CStr(dateCell.Text))
    displayedText = Replace(displayedText, Chr(160), " ")
    displayedText = Replace(displayedText, vbTab, " ")
    displayedText = Trim(displayedText)

If displayedText = "" Then
        Exit Function
    End If

dateOnly = displayedText

If InStr(1, dateOnly, " ") > 0 Then
        dateOnly = Split(dateOnly, " ")(0)
    End If

dateOnly = Trim(dateOnly)

If InStr(1, dateOnly, "/") = 0 Then
        Exit Function
    End If

dateParts = Split(dateOnly, "/")