Private Sub M1_Reset_Sheet()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 12 May 21

'Resets All Sheets
'=================================================================================================================================

'Confirmation
    'User Input
        iRConf = MsgBox("This will remove submitted SKUs" & vbCrLf & vbCrLf & _
            "Proceed?", vbYesNo, "Reset Confirmation")
    'If no
        If iRConf = vbNo Then
            Exit Sub
        End If

'Reset Data SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Delete All
        On Error Resume Next
        Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
    'Set Dropdown for Status
        'Block/Unblock
            With iwsDT1.Range("B2:B1000").Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='" & iwsCS.Name & "'!$T$3:$T$4"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

'Reset Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
    'Set Font
        With iwsDISP1.Range("E7:W" & Range("A" & Rows.Count).End(xlUp).Row).Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
        End With
    'Find Unblock from previous run and set to open
        For Each iColCK In Range("E6:W6")
            'Select and Get Column Unblock
                iColCK.Select
                iColFmt = Left(Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1), _
                    Application.Search("$", Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1)) - 1)
            'Loop and Set Unblock to Open
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Open"
                        'Set Green Format
                            With Range(iColFmt & iDelCt).Interior
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                                .Color = 5296274
                                .TintAndShade = 0
                                .PatternTintAndShade = 0
                            End With
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
            'Loop and Set Block to Closed
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Closed"
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
        Next iColCK

'Reset Error Report
    'Activate Sheet
        iwsDISP2.Activate
    'Remove All Data
        On Error Resume Next
        Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
        Range("D1") = "Error Reason"
        
'Finalize Report
    'Set Final Views
        iwsDISP1.Activate
        Range("A1").Select
        iwsDT1.Activate
        Range("A1").Select
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        MsgBox ("Sheets Reset!")

End Sub
Private Sub M2_Load_Submission_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Loads Data
'=================================================================================================================================

Dim iwbSub As Workbook
'Select File to Load
    'Set Pathway to Open to
        'ChDir ActiveWorkbook.Path,
    'Run Dialog with Cancellation Error Handling
        cancel = Application.GetOpenFilename _
        (Title:="Select Central OU Submission Form to Load")
        If cancel = False Then
            MsgBox ("Import Session Ended")
            Exit Sub
        End If
        With Workbooks.Open(cancel)
        End With
    'Set variable Name
        Set iwbSub = ActiveWorkbook

Dim iwsImp As Worksheet
'Loop Through All Worksheets
    'Activate Workbook
        iwbSub.Activate
    'Loop and Import Data
        For Each iwsImp In Worksheets
            'Activate Workbook
                iwbSub.Activate
            'Unhide workbook if necessary
                On Error Resume Next
                iwsImp.Visible = True
            'Activate Sheet
                iwsImp.Activate
            'Check Sheet Name - Save if is registered site
                'Get Initial Sheet Name
                    iLoc = Left(iwsImp.Name, 4)
                'Skip if Sheet Name is List
                    If iLoc = "List" Then
                        GoTo iFunctSkip
                    End If
                'Execute Test
                    'Activate Sheet
                        iwsImp.Activate
                    'Check Database
                        iLocTest = Application.IfError(Application.Match(iLoc, iwsCS.Range("$O:$O"), 0), 0) + _
                            Application.IfError(Application.Match(iLoc, iwsCS.Range("$N:$N"), 0), 0)
                    'Actions Test
                        'If Valid - Import Data
                            If iLocTest > 0 Then
                                'Test If Data Exists to Import
                                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                                        'Copy Data
                                            iwsImp.Activate
                                            Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                                        'Paste Data
                                            iwsDT1.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Fill Site Number
                                            Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1 & _
                                                ":C" & Range("A" & Rows.Count).End(xlUp).Row) = iLoc
                                    Else
                                        GoTo iFunctSkip
                                    End If
                        'If Not Valid Set Warning
                            Else
                                'Generate Error message
                                    MsgBox ("WARNING! Invalid sheet name detected!" & vbCrLf & vbCrLf & _
                                        "Please validate:" & vbCrLf & vbCrLf & _
                                        iwsImp.Name)
                                'Error handle
                                    GoTo iFunctSkip
                            End If
iFunctSkip:
        Next iwsImp

'Close Workbook with no Saving
    iwbSub.Close savechanges:=False

'Finalize Report
    'Set Final View on Data
        iwsDT1.Activate
        Range("A1").Select
    'Set Final View
        iwsCS.Activate
        Range("A1").Activate
    'Completion message
        MsgBox ("Submission Data Loaded!")

End Sub
Private Sub M3_Compile_Report()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'User Option Select
iERRSelect:
    iUSelect = InputBox("Enter a Number to Select Action:" & vbCrLf & vbCrLf & _
        "   1 - RUN ALL" & vbCrLf & vbCrLf & _
        "   2 - Compile Data" & vbCrLf & vbCrLf & _
        "   3 - Finalize Report" & vbCrLf & vbCrLf & _
        "   0 - Cancel Operation" & vbCrLf, "Select Action")
        
'Check and Save Variables
    'Activate Sheet
        iwsCS.Activate
    'Fiscal Week
        Select Case iwsCS.Range("D2")
            Case 1 To 53        'Valid Entry
                'Continue
            Case Else           'Invalid Entry
                'Error Message
                    MsgBox ("ERROR! Invalid Fiscal Week!" & vbCrLf & vbCrLf & _
                        "Please make a valid entry!" & vbCrLf & vbCrLf & _
                        "Exiting Sub!")
                'Exit Sub
                    Exit Sub
        End Select
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
        
'Case select to set run
    Select Case iUSelect
        Case 1      'RUN All
            'Execute Call
                Call S2_Compile_Data
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Run All Complete!"
        Case 2      'Compile Data
            'Execute Call
                Call S2_Compile_Data
            'Set Completion Message
                iCMsg = "Data Compile Complete!"
        Case 3      'Finalize Report
            'Execute Call
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Report Finalized!"
        Case 0      'Cancel Operation
            'Set Cancellation message
                iCMsg = "Procedure Cancelled!"
        Case Else   'Error Handle
            'Error message
                MsgBox ("ERROR! Please make a valid selection!")
            'Error Handle
                GoTo iERRSelect
    End Select

'Finalize Report
    'Set Error Report Warning
        'Activate Sheet
            iwsDISP2.Activate
        'Item Count
            iErCt = Range("A" & Rows.Count).End(xlUp).Row - 1
    'Final View
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        If iErCt > 0 Then
            'Completion message With Error Report Warning
                MsgBox (iCMsg & vbCrLf & vbCrLf & _
                    "WARNING! " & iErCt & " items reported on error report!" & vbCrLf & vcbrlf)
        Else
            'Standard Completion Message
                MsgBox (iCMsg)
        End If

End Sub
Private Sub M4_Generate_Submission_Form()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Generates Distro Form
'=================================================================================================================================

'Save Variables
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
    'Day
        iDy = Day(Date + 1)
    'Month
        iMth = Month(Date + 1)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date + 1)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew = "Central - SKU Blocking Submission File - To Be Loaded-" & iDStr & ".xlsx"

'Activate Sheet
    iwsCS.Activate
    
Dim iwbSub As Workbook
Dim iwsSub As Worksheet
'Generage New sheet
    'Add New Workbook
        Workbooks.Add
        Set iwbSub = ActiveWorkbook
        Set iwsSub = iwbSub.ActiveSheet

'Generate List Sheet
    'Activate Workbook
        iwsSub.Activate
    'Change Sheet Name
        iwsSub.Name = "List"
    'Set List
        Range("A1") = "Block"
        Range("A2") = "Unblock"
    'Generate New List
        'Copy Data
            iwsCFT1.Activate
            Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Paste Data
            iwsSub.Activate
            Range("C1").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Convert To Numbers
            iwsSub.Activate
            Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(1, 1), TrailingMinusNumbers:=True

Dim iwsTSN As Worksheet
'Loop and Generate Sheets
    'Activate Sheet
        iwsCS.Activate
    'Loop Through OU List and Grab all West
        For Each iOU In Range("Q3:Q" & Range("Q" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsCS.Activate
            'Select and get row
                iOU.Select
                iOUR = iOU.Row
            'Save Data
                iNum = Range("O" & iOUR)        'MU
                iOUT = Range("Q" & iOUR)        'OU
                iLoc = Range("S" & iOUR)        'Location
                iSSTr = iNum & "-" & iLoc       'Sheet String
            'Check if OU is West
                Select Case iOUT
                    Case "Central"
                        'Activate Workbook
                            iwbSub.Activate
                        'Add Sheet
                            On Error Resume Next
                            Sheets.Add(After:=iwbSub.Sheets(iwbSub.Sheets.Count)).Name = iSSTr
                            Set iwsTSN = iwbSub.Sheets(iSSTr)
                        'Activate Sheet
                            iwsTSN.Activate
                        'Generate Headers
                            Range("A1") = "SKU"
                            Range("B1") = "Status"
                            Range("C1") = "Description"
                        'Generate List
                            With Range("B2:B500").Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsSub.Name & "'!$A$1:$A$2"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                        'Generate Formula for Description
                            iwsTSN.Activate
                            Range("C2") = "=IF(ISBLANK($A2)=TRUE,"""",XLOOKUP($A2," & iwsSub.Name & "!$C:$C," & iwsSub.Name & "!$D:$D,"""",0))"
                            Range("C2").AutoFill Destination:=Range("C2:C500")
                End Select
        Next iOU

'Save Book
    'Activate Workbook
        iwbSub.Activate
    'Hide List Sheet
        On Error Resume Next
        iwsSub.Visible = False
    'Save Copy
        iwbSub.SaveCopyAs iSPth & iwbNew
    'Close Submission Book No Save
        iwbSub.Close savechanges:=False

'Finalize Report
    'Activate Sheet
        iwsCS.Activate
    'Set Final View
        Range("A1").Select
    'Completion Message
        MsgBox ("Submission Form Generated!")
        
End Sub
Private Sub M5_Archive_SKUs()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 9 Jun 21

'Executes SKU Archival
'=================================================================================================================================

'Warning Message
    

'Loop to Archive Items based on Rules
    'Activate Sheet
        iwsDISP1.Activate
    'Loop Through SKUs
        For Each IArc In Range("A7:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDISP1.Activate
            'Select and Get Row
                IArc.Select
                iArcR = IArc.Row
            'Save Variables
                iODL = UCase(Range("C" & iArcR))                                                        'Delist Flag
                iStat = Range("D" & iArcR)                                                              'Status
                iOCt = Application.CountIf(iwsDISP1.Range("$E" & iArcR & ":$K" & iArcR & ""), "Open")   'Open Count
            'Initial Delist Check
                Select Case iODL
                    Case "X"            'Item Delisted
                        'Check Open Count
                            Select Case iOCt
                                Case "0"        'Move
                                    'Import
                                        'Copy
                                            iwsDISP1.Activate
                                            Range("A" & iArcR & ":K" & iArcR).Copy
                                        'Paste Data
                                            iwsDT2.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Set Date Stamp
                                            Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                    'Set Archive Flag
                                        iwsDISP1.Activate
                                        Range("C" & iArcR) = "ARCHIVED"
                                Case Else       'Still Open in Locations
                                    'No Action
                            End Select
                    Case Else           'Not On Delist
                        'Check Status
                            Select Case iStat
                                Case "LTO"      'LTO Status
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0                      'None Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else       'Some Locations Open
                                                'No Action
                                        End Select
                                Case "Long Term OOS", "", " ", 0        'Long Term Out of Stock and Blanks
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0      'All Closed
                                                'No Action
                                            Case 7     'All Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else   'Some location Open
                                                'No Action
                                        End Select
                            End Select
                        
                End Select
        Next IArc
    
'Remove Archived Items
    'Activate Sheet
        iwsDISP1.Activate
    'Loop and Delete Archived Rows
        'Set Initial Deletion Count
            iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
        'Delete Items
            Do Until iDelCt = 0
                'Get Row
                    iDelRw = Application.Match("ARCHIVED", iwsDISP1.Range("C:C"), 0)
                'Select and Delete Row
                    Range("C" & iDelRw).Select
                    Range("C" & iDelRw).EntireRow.Delete
                'Reset Deletion Count
                    iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
            Loop

'Check Archived SKUs for Items more than 90 days old
    'Activate Sheet
        iwsDT2.Activate
    'Insert Formula For Check
        Range("Y7") = "=IF(TODAY()-$L7<=90,""1-KEEP"",""2-DELETE"")"
        Range("Y7").AutoFill Destination:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Delete Items
        'Sort To Group Deletion Items Together
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        'Deletion Cycle
            'Set Initial deletion Count
                iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
            'Loop and Delete
                Do Until iDelCt = 0
                    'Select and Get Rows
                        'Start
                            iDRw1 = Application.Match("2-DELETE", iwsDT2.Range("Y:Y"), 0)
                        'End
                            If iDelCt > 1000 Then
                                iDRw2 = iDRw1 + 999
                            Else
                                iDRw2 = iDRw1 + (iDelCt - 1)
                            End If
                        'Select and Delete Selection
                            Range("Y" & iDRw1 & ":Y" & iDRw2).Select
                            Range("Y" & iDRw1 & ":Y" & iDRw2).EntireRow.Delete
                        'Set Initial deletion Count
                            iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
                Loop
        'Remove Identifiers
            Range("Y:Y").Delete
        'Reset Date Sort
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("L7:L" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:L" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    
'Finalize Report
    'Set View
        'Activate Sheet
            iwsDISP1.Activate
        'Set Selection
            Range("A1").Select
            Range("E7").Select
    'Completion message
        MsgBox ("SKU Archival Complete!")
            
End Sub
Private Sub S2_Compile_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")

'Refresh CRAFT
    'Activate Sheet
        iwsCFT1.Activate
    'Clear BIB Identity
        Columns("D:D").Delete
    'Refresh Data
        iwb.RefreshAll
    'Insert Identity Formula
        'Range("D1") = "=IF(IFERROR(SEARCH(""BIB"",$C1),0)>0,""BIB"","""")"
        'Range("D1").AutoFill Destination:=Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row)
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        'Application.CutCopyMode = False

'Correct Format of SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Trim Data
        'Insert Trim Formula
            Range("D2") = "=TRIM(SUBSTITUTE($A2,CHAR(160),CHAR(32)))"
        'Autofill and Copy Paste Results
            Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Remove Fixy
            Columns("D:D").Delete
    'Activate Sheet
        iwsDT1.Activate
        Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
    'Clear Blanks First
        'Initial Remove
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        'Final Check
            'Insert Space Check
                Range("D2") = "=IF(LEN(TRIM($A2))=0,""2-DELETE"",""1-KEEP"")"
            'Fill and Copy Paste Results
                Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            'Loop and Check if items need deletion
                'Set Initial Deletion Count
                    iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                'Loop and Remove Items
                    Do Until iDelCt = 0
                        'Get Row
                            iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                        'Select and Delete
                            Range("D" & iDelRw).Select
                            Range("D" & iDelRw).EntireRow.Delete
                        'Reset Deletion Count
                            iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                    Loop
            'Remove Identifier
                Columns("D:D").Delete
    'Generate Correction Formula
        Range("D2") = "=IFERROR(VALUE(TRIM($A2)),""ERROR"")"
    'Fill Data
        Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Error Handle
        If Application.IfError(Application.Match("ERROR", iwsDT1.Range("D:D"), 0), 0) > 0 Then
            'Error Message
                MsgBox ("ERROR! SKU " & iwsDT1.Range("A" & Application.Match("ERROR", iwsDT1.Range("D:D"), 0)) & _
                    " is not in number format!" & vbCrLf & vbCrLf & _
                    "Please correct and re run!" & vbCrLf & vbCrLf & _
                    "Exiting Sub!")
            'Exit sub
                Exit Sub
        End If
    'Import to SKU list and Remove Fix Column
        'Import Data
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Clear Fix Column
            Columns("D:D").Delete

'Execute Rules
    'Replicate Actions
        'Loop Through Replicate Actions Database
            'Activate Sheet
                iwsCS.Activate
            'Generate Temp Sheet
                'Remove Temp Sheet if Pre Existing
                    On Error Resume Next
                    iwb.Sheets("TEMP").Delete
                'Generate New Temp Sheet
                    Dim iwsTMP As Worksheet
                    Sheets.Add.Name = "TEMP"
                    Set iwsTMP = iwb.Sheets("TEMP")
                'Generate Headers
                    iwsTMP.Activate
                    Range("A1") = "SKU"
                    Range("B1") = "Status"
                    Range("C1") = "Plant"
            'Activate Sheet
                iwsCS.Activate
            'Execute Loop and Search
                For Each iRA In Range("M3:M" & Range("M" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsCS.Activate
                    'Select and Save Data
                        iRA.Select
                        iRAR = iRA.Row
                        iFP = Range("M" & iRAR)
                        iTP = Range("N" & iRAR)
                    'Execute Loop in Submitted SKUs
                        'Activate Sheet
                            iwsDT1.Activate
                        'Loop
                            For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Save Variables
                                    iCK.Select
                                    iCKR = iCK.Row
                                    iPlt = Range("C" & iCKR)
                                'Check if Replication Required
                                    If iPlt = iFP Then
                                        'Save Data
                                            iSKU = Range("A" & iCKR)
                                            iStat = Range("B" & iCKR)
                                        'Set Temp Row
                                            iwsTMP.Activate
                                            iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
                                        'Insert Data
                                            Range("A" & iTMPR) = iSKU
                                            Range("B" & iTMPR) = iStat
                                            Range("C" & iTMPR) = iTP
                                    End If
                            Next iCK
                Next iRA
            'Move Data Back to Data Sheet
                'Activate Sheet
                    iwsTMP.Activate
                'Check if Import Required
                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                        'Copy Data
                            iwsTMP.Activate
                            Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                        'Paste Data
                            iwsDT1.Activate
                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                            Application.CutCopyMode = False
                    End If
            'Delete Temp Sheet
                On Error Resume Next
                iwsTMP.Delete

'Execute Data Scrub
    'Reset Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Delete Data
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
        'Header Set
            Range("A1") = "SKU"
            Range("B1") = "Status"
            Range("C1") = "Plant"
            Range("D1") = "Error Reason"
    'Insert Identifiers
        'Activate Sheet
            iwsDT1.Activate
        'Insert ID
            Range("E2") = "=$A2&$C2"
            Range("F2") = "=$A2&$B2&$C2"
        'Autofill
            Range("E2:F2").AutoFill Destination:=Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
    'Remove Duplicates with Similar Status
        'Activate Sheet
            iwsDT1.Activate
            On Error Resume Next
            iwsDT1.Range("$A$1:$F$" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=6, Header:=xlYes
    'Check for Duplicates with Different Status
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Check Each item
            For Each iDDS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iDDS.Select
                    iDDSRw = iDDS.Row
                'Set Counts
                    iSPCt = Application.CountIfs(iwsDT1.Range("$E:$E"), iwsDT1.Range("$E" & iDDSRw))        'SKU & Plant
                    iSSPCt = Application.CountIfs(iwsDT1.Range("$F:$F"), iwsDT1.Range("$F" & iDDSRw))       'SKU, Status & Plant
                'Move to Error Report if Necessary
                    If iSPCt <> iSSPCt Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iDDSRw & ":C" & iDDSRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                Range("D" & iTDR) = "Duplicate with Different Statuses"
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iDDSRw) = "2-DELETE"
                    End If
            Next iDDS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove Columns
                Columns("E:F").Delete
    'Validate Status
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($B2,'" & iwsCS.Name & "'!$T$3:$T$4,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVS.Select
                        iVSRw = iVS.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVSRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVSRw & ":C" & iVSRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Status Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVSRw) = "2-DELETE"
                        End If
                Next iVS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Validate Plant
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$O$3:$O$41,0),0)+" & _
                "IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$N$3:$N$41,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVP.Select
                        iVPRw = iVP.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVPRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVPRw & ":C" & iVPRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Plant Number Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVPRw) = "2-DELETE"
                        End If
                Next iVP
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Check for Items to Exclude
        'Activate Sheet
            iwsDT1.Activate
        'Insert Formula
            Range("E2") = "=IF(IFERROR(MATCH($A2,'" & iwsCS.Name & "'!$AD:$AD,0),0)>0,""EXCL"","""")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Loop and Check Each item
            For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iVP.Select
                    iVPRw = iVP.Row
                'Move to Error Report if Necessary
                    If Range("E" & iVPRw) = "EXCL" Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iVPRw & ":C" & iVPRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                'Range("D" & iTDR) = "Unable to process BIB Items"
                                Range("D" & iTDR) = Application.XLookup(Range("$A" & iTDR), iwsCS.Range("$AD:$AD"), iwsCS.Range("$AE:$AE"), 0, 0)
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iVPRw) = "2-DELETE"
                    End If
            Next iVP
            
    'Format Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Set Widths
            Columns("A:C").ColumnWidth = 12
            Columns("D:D").ColumnWidth = 35
        'Set Borders
            With Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).Borders
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
    'Remove Items From Main Data Set
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Delete
            'Set Initial Deletion Count
                iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
            'Loop and Delete Items
                Do Until iDelCt = 0
                    'Get Row
                        iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                    'Select and Delete
                        Range("D" & iDelRw).Select
                        Range("D" & iDelRw).EntireRow.Delete
                    'Reset Initial Deletion Count
                        iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                Loop

'Loop Through Each SKU and set tracker
    'Activate Sheet
        iwsDT1.Activate
    'Loop
        For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDT1.Activate
            'Select and get Data
                iSKU.Select
                iSRw = iSKU.Row
            'Save data Sheet Variables
                'Activate Sheet
                    iwsDT1.Activate
                'Set Variables
                    iSKUN = Range("A" & iSRw)                           'SKU
                    iStat = Range("B" & iSRw)                           'Status
                    iPlnt = Range("C" & iSRw)                           'Plant
            'Set Tracker
                'Activate Sheet
                    iwsDISP1.Activate
                'Check if New Item - Add to List if Necessary if already entered find row
                    If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
                        'Set Working Row
                            iWRw = Range("A" & Rows.Count).End(xlUp).Row + 1
                        'Enter Info
                            Range("A" & iWRw) = iSKUN
                            Range("B" & iWRw) = Application.XLookup(Application.Text(iSKUN, 0), iwsCFT1.Range("A:A"), iwsCFT1.Range("B:B"), "N/A", 0)
                        'Generate Status List
                            With Range("D" & iWRw).Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsCS.Name & "'!$AA$3:$AA$5"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                    Else
                        'Set Working Row
                            iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
                    End If
            'Set Column/Range Variable
                'Working Column
                    iWCol = Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0)
                    iWCol = Left(Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1), _
                        Application.Search("$", Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1)) - 1)
                'Working Range
                    Dim iWRng As Range
                    Set iWRng = Range(iWCol & iWRw)
                    iWRng.Select
            'Set Block/Unblock
                Select Case iStat
                    Case "Block"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Week
                            iWRng = "Block"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                    Case "Unblock"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Open
                            iWRng = "Unblock"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                End Select
        Next iSKU

'Clean Sheet
    'Get End of DataSet
        'Activate Sheet
            iwsDISP1.Activate
        'Final Pull and Variable Set
            iECol = Rows("6:6").End(xlToRight).Column
            iECol = Left(Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1), _
                Application.Search("$", Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1)) - 1)
    'Double Check Descriptions
        'Activate Sheet
            iwsDISP1.Activate
        'Loop and Validate Data
            For Each iDCD In Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row)
                'Select and Get Row
                    iDCD.Select
                    iDCDRw = iDCD.Row
                'Check if New Description Required
                    If Range("B" & iDCDRw) = "N/A" Then
                        Range("B" & iDCDRw) = Application.XLookup(Application.Text(Range("A" & iDCDRw), 0), _
                            iwsCFT1.Range("A:A"), _
                            iwsCFT1.Range("B:B"), _
                            "N/A", 0)
                    End If
            Next iDCD
    'Fill Blanks
        'Activate Sheet
            iwsDISP1.Activate
        'Fill data if Necessary
            If Application.CountBlank(iwsDISP1.Range("$E$7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row)) > 0 Then
                'Select Blanks
                    On Error Resume Next
                    Range("$E7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Select
                'Set Formatting
                    'Set Text
                        Selection = "Open"
                    'Highlighting
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 5296274
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    'Font
                        With Selection.Font
                            .ThemeColor = xlThemeColorLight1
                            .TintAndShade = 0
                        End With
            End If

'Final Formatting Cleanup
    'Activate Sheet
        iwsDISP1.Activate
    'Set Borders
        With Range("A7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    'Font Size and Format
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Font.Size = 10
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlLeft
    'Set Grey Details Highlighting
        With Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.149998474074526
            .PatternTintAndShade = 0
        End With

End Sub
Private Sub S3_Finalize_Report()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")
    'Save Path
        iSPth = iwsCS.Range("D4")
    'Email Confirmation - Processing
        iEMConf = iwsCS.Range("D6")
    'Email Confirmation - General Distr
        iEMConf1 = iwsCS.Range("D8")
    'Day
        iDy = Day(Date)
    'Month
        iMth = Month(Date)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew1 = "Central - SKU Blocking Tracker - " & iDStr & ".xlsm"
        iwbNew2 = "Central - SKU Blocking Data - " & iDStr & ".xlsm"
    'Item error Count - Save Table If Necessary
        'Activate Sheet
            iwsDISP2.Activate
        'Set Count
            iErrCt = Range("A" & Rows.Count).End(xlUp).Row - 1
        'Set Range
            Set iDtaRng = iwsDISP2.Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row + 1)
    
'Generate Date on Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
        Range("C1") = "Current Week " & iFWk

Dim iwbFmt As Workbook
Dim iwsVis As Worksheet
'Generate Copies
    'Tracker
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew1
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew1
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDISP1.Name).Activate
                'Set View
                    Range("A1").Select
                    Range("E7").Select
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDISP1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True
    'Submission Data
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew2
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew2
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDT1.Name).Activate
                'Set View
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDT1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True

'Distribute to Processing if Option Selected
    If iEMConf = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("K" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMTo = iEMTo & Range("K" & iEMRw) & "; "
                Next iEM
            Else
                iEMTo = ""
            End If
        'Generate CC Email
            If Range("L" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("L3:L" & Range("L" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMCC = iEMCC & Range("L" & iEMRw) & "; "
                Next iEM
            Else
                iEMCC = ""
            End If
        'Generate Subject Line
            iSubj = "Central - Master Data Delist Tracker - " & iDStr
        'Generate Body
            iMsg = "Hello Everyone," & vbCrLf & vbCrLf & _
                "Attached is the delist tracker for " & iDStr & "." & vbCrLf & vbCrLf & _
                "Thanks," & vbCrLf
        'Generate Email
        Dim olApp As Object
        Dim olMail As Object
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMTo
                    .CC = iEMCC
                    .Subject = iSubj
                    .body = iMsg
                    .Attachments.Add iSPth & iwbNew2
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If

'Distribute to General Option Selected
    If iEMConf1 = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("I" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGTo = iEMGTo & Range("I" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGTo = ""
            End If
        'Generate CC Email
            If Range("J" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("J3:J" & Range("J" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGCC = iEMGCC & Range("J" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGCC = ""
            End If
        'Generate Subject Line
            iSubjG = "Central - Delist Tracker - " & iDStr
        'Generate Body - Depends on If Error items Found
            If iErrCt = 0 Then
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Thanks," & "<br>"
            Else
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Items were not loaded due to errors detected" & "<br>" & _
                    "Please review and resubmit the following items:" & "<br>" & "<br>" & _
                    RangetoHTML(iDtaRng) & "<br>" & "<br>" & "Thanks," & "<br>"
            End If
        'Generate Email
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMGTo
                    .CC = iEMGCC
                    .Subject = iSubjG
                    .HTMLbody = iMsgG
                    .Attachments.Add iSPth & iwbNew1
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If
        
End Sub
Private Sub Reconcile()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Week
iFWk = iwsCS.Range("D2")

'Execute Reset Call
Call M1_Reset_Sheet

Dim iwbSAP As Workbook
Dim iwsSAP As Worksheet
'Select File to Load
'Set Pathway to Open to
'ChDir ActiveWorkbook.Path
'Run Dialog with Cancellation Error Handling
cancel = Application.GetOpenFilename _
(Title:="Select Central OU Reconcile File to Load")
If cancel = False Then
MsgBox ("Import Session Ended")
Exit Sub
End If
With Workbooks.Open(cancel)
End With
'Set variable Name
Set iwbSAP = ActiveWorkbook
Set iwsSAP = iwbSAP.ActiveSheet

Application.ScreenUpdating = False

Dim iwsTMP1 As Worksheet
'Generate Temp Sheet
'Activate Sheet
iwb.Activate
'Remove Temp Sheet if already exists
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Sheet
Sheets.Add.Name = "TEMP"
Set iwsTMP1 = iwb.Sheets("TEMP")

'Import Data To Main Sheet
'Copy Data
iwsSAP.Activate
Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsTMP1.Activate
Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Close SAP workbook no save
iwbSAP.Close savechanges:=False

'Execute format and clean
'Clean to just relevant Plants and SKUs
'Activate Sheet
iwsTMP1.Activate
'Text to columns material
Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Formula Insert and Fill
Range("G2") = "=IF(AND(" & _
"COUNTIFS('" & iwsDISP1.Name & "'!$6:$6,$C2)>0," & _
"COUNTIFS('" & iwsDISP1.Name & "'!$A:$A,$D2)>0)," & _
"""1-KEEP"",""2-DELETE"")"
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Sort To Group Items for deletion
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:G" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("G:G"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("G" & iSRw & ":G" & iERw).Select
Range("G" & iSRw & ":G" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0), 0)
Loop
'Remove Identifier
Columns("G:G").Delete
'Duplicates Scrub
'Activate sheet
iwsTMP1.Activate
'Generate Duplicates Identifier
Range("G1") = "Unique ID"
Range("H1") = "Duplicates Count"
'Insert Formulas
Range("G2") = "=$C2&$D2"
Range("H2") = "=IF(COUNTIFS($G:$G,$G2)>1,""2-DUP"","""")"
Range("G2:H2").AutoFill Destination:=Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Duplicates Correction if detected
If Application.CountIfs(iwsTMP1.Range("$H:$H"), "2-DUP") > 1 Then
'Execute Scrub
'Sort data for Scrub
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Flag Items for Deletion
'Activate Sheet
iwsTMP1.Activate
'Loop and Execute Ident
For Each iDupCt In Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row)
'Select and Get row
iDupCt.Select
iDCRw = iDupCt.Row
'Save Start and End Rows
iUIDS = Range("G" & iDCRw)
iDRS = Application.Match(iUIDS, iwsTMP1.Range("G:G"), 0)
iDRE = iDRS + (Application.CountIfs(iwsTMP1.Range("$G:$G"), iUIDS) - 1)
'Enter Formula
If Application.Rank(iwsTMP1.Range("$E" & iDCRw), iwsTMP1.Range("$E" & iDRS & ":$E" & iDRE), 0) > 1 Then
Range("H" & iDCRw) = "2-DELETE"
Else
Range("H" & iDCRw) = "1-KEEP"
End If
Next iDupCt
'Sort and Delete all Items flagged for deletion
'Activate Sheet
iwsTMP1.Activate
'Sort Items for Deletion Groups
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("H:H"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("H" & iSRw & ":H" & iERw).Select
Range("H" & iSRw & ":H" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0), 0)
Loop
End If
'Identify Status
'Reset Columns
Columns("G:H").Delete
Range("G1") = "Status"
'Generate Formula
Range("G2") = "=IF(YEAR($F2)=9999,""Unblock"",""Block"")"
Range("G2") = "=IF($F2 "
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Resort Data
Columns("C:C").Cut
Columns("A:A").Insert
Columns("G:G").Cut
Columns("A:A").Insert
Columns("E:E").Cut
Columns("A:A").Insert
'Import data to Submitted SKUs Sheet
iwsTMP1.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
iwsDT1.Activate
Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete Temp Sheet
iwsTMP1.Delete

'Loop Through Each SKU and set tracker
'Replicate Actions
'Loop Through Replicate Actions Database
'Activate Sheet
iwsCS.Activate
'Generate Temp Sheet
'Remove Temp Sheet if Pre Existing
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Temp Sheet
Dim iwsTMP As Worksheet
Sheets.Add.Name = "TEMP"
Set iwsTMP = iwb.Sheets("TEMP")
'Generate Headers
iwsTMP.Activate
Range("A1") = "SKU"
Range("B1") = "Status"
Range("C1") = "Plant"
'Activate Sheet
iwsCS.Activate
'Execute Loop and Search
For Each iRA In Range("AB3:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsCS.Activate
'Select and Save Data
iRA.Select
iRAR = iRA.Row
iFP = Range("AB" & iRAR)
iTP = Range("AC" & iRAR)
'Execute Loop in Submitted SKUs
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Save Variables
iCK.Select
iCKR = iCK.Row
iPlt = Range("C" & iCKR)
'Check if Replication Required
If iPlt = iFP Then
'Save Data
iSKU = Range("A" & iCKR)
iStat = Range("B" & iCKR)
'Set Temp Row
iwsTMP.Activate
iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
'Insert Data
Range("A" & iTMPR) = iSKU
Range("B" & iTMPR) = iStat
Range("C" & iTMPR) = iTP
End If
Next iCK
Next iRA
'Move Data Back to Data Sheet
'Activate Sheet
iwsTMP.Activate
'Check if Import Required
If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
'Copy Data
iwsTMP.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsDT1.Activate
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
'Delete Temp Sheet
On Error Resume Next
iwsTMP.Delete
'Update Tracker
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Select and get Data
iSKU.Select
iSRw = iSKU.Row
'Save data Sheet Variables
'Activate Sheet
iwsDT1.Activate
'Set Variables
iSKUN = Range("A" & iSRw) 'SKU
iStat = Range("B" & iSRw) 'Status
iPlnt = Range("C" & iSRw) 'Plant
'Set Tracker
'Activate Sheet
iwsDISP1.Activate
'Check if New Item - Skip
If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
GoTo iSkipProcess
Else
'Set Working Row
iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
End If
'Set Column/Range Variable
'Working Column
'Get Working Column
iWCol = Application.IfError(Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0), 0)
'Error Handler
If iWCol = 0 Then
GoTo iSkipProcess
Else
'Convert Column Number to Letter
iWCol = Left(Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1), _
Application.Search("$", Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1)) - 1)
End If
'Working Range
Dim iWRng As Range
Set iWRng = Range(iWCol & iWRw)
iWRng.Select
'Set Block/Unblock
Select Case iStat
Case "Block"
'Activate Sheet
iwsDISP1.Activate
'Set Week
iWRng = "Block"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
Case "Unblock"
'Activate Sheet
iwsDISP1.Activate
'Set Open
iWRng = "Unblock"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
End Select
iSkipProcess:
Next iSKU

'Completion Message
Application.ScreenUpdating = False
MsgBox ("Mass System Reconciliation Complete!")

End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
    'Create Temp File
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                             "align=left x:publishsource=")
    'Close TempWB
        TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
        Kill TempFile
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
End Function
Private Sub M1_Reset_Sheet()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 12 May 21

'Resets All Sheets
'=================================================================================================================================

'Confirmation
    'User Input
        iRConf = MsgBox("This will remove submitted SKUs" & vbCrLf & vbCrLf & _
            "Proceed?", vbYesNo, "Reset Confirmation")
    'If no
        If iRConf = vbNo Then
            Exit Sub
        End If

'Reset Data SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Delete All
        On Error Resume Next
        Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
    'Set Dropdown for Status
        'Block/Unblock
            With iwsDT1.Range("B2:B1000").Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='" & iwsCS.Name & "'!$T$3:$T$4"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

'Reset Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
    'Set Font
        With iwsDISP1.Range("E7:W" & Range("A" & Rows.Count).End(xlUp).Row).Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
        End With
    'Find Unblock from previous run and set to open
        For Each iColCK In Range("E6:W6")
            'Select and Get Column Unblock
                iColCK.Select
                iColFmt = Left(Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1), _
                    Application.Search("$", Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1)) - 1)
            'Loop and Set Unblock to Open
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Open"
                        'Set Green Format
                            With Range(iColFmt & iDelCt).Interior
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                                .Color = 5296274
                                .TintAndShade = 0
                                .PatternTintAndShade = 0
                            End With
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
            'Loop and Set Block to Closed
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Closed"
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
        Next iColCK

'Reset Error Report
    'Activate Sheet
        iwsDISP2.Activate
    'Remove All Data
        On Error Resume Next
        Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
        Range("D1") = "Error Reason"
        
'Finalize Report
    'Set Final Views
        iwsDISP1.Activate
        Range("A1").Select
        iwsDT1.Activate
        Range("A1").Select
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        MsgBox ("Sheets Reset!")

End Sub
Private Sub M2_Load_Submission_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Loads Data
'=================================================================================================================================

Dim iwbSub As Workbook
'Select File to Load
    'Set Pathway to Open to
        'ChDir ActiveWorkbook.Path,
    'Run Dialog with Cancellation Error Handling
        cancel = Application.GetOpenFilename _
        (Title:="Select Central OU Submission Form to Load")
        If cancel = False Then
            MsgBox ("Import Session Ended")
            Exit Sub
        End If
        With Workbooks.Open(cancel)
        End With
    'Set variable Name
        Set iwbSub = ActiveWorkbook

Dim iwsImp As Worksheet
'Loop Through All Worksheets
    'Activate Workbook
        iwbSub.Activate
    'Loop and Import Data
        For Each iwsImp In Worksheets
            'Activate Workbook
                iwbSub.Activate
            'Unhide workbook if necessary
                On Error Resume Next
                iwsImp.Visible = True
            'Activate Sheet
                iwsImp.Activate
            'Check Sheet Name - Save if is registered site
                'Get Initial Sheet Name
                    iLoc = Left(iwsImp.Name, 4)
                'Skip if Sheet Name is List
                    If iLoc = "List" Then
                        GoTo iFunctSkip
                    End If
                'Execute Test
                    'Activate Sheet
                        iwsImp.Activate
                    'Check Database
                        iLocTest = Application.IfError(Application.Match(iLoc, iwsCS.Range("$O:$O"), 0), 0) + _
                            Application.IfError(Application.Match(iLoc, iwsCS.Range("$N:$N"), 0), 0)
                    'Actions Test
                        'If Valid - Import Data
                            If iLocTest > 0 Then
                                'Test If Data Exists to Import
                                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                                        'Copy Data
                                            iwsImp.Activate
                                            Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                                        'Paste Data
                                            iwsDT1.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Fill Site Number
                                            Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1 & _
                                                ":C" & Range("A" & Rows.Count).End(xlUp).Row) = iLoc
                                    Else
                                        GoTo iFunctSkip
                                    End If
                        'If Not Valid Set Warning
                            Else
                                'Generate Error message
                                    MsgBox ("WARNING! Invalid sheet name detected!" & vbCrLf & vbCrLf & _
                                        "Please validate:" & vbCrLf & vbCrLf & _
                                        iwsImp.Name)
                                'Error handle
                                    GoTo iFunctSkip
                            End If
iFunctSkip:
        Next iwsImp

'Close Workbook with no Saving
    iwbSub.Close savechanges:=False

'Finalize Report
    'Set Final View on Data
        iwsDT1.Activate
        Range("A1").Select
    'Set Final View
        iwsCS.Activate
        Range("A1").Activate
    'Completion message
        MsgBox ("Submission Data Loaded!")

End Sub
Private Sub M3_Compile_Report()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'User Option Select
iERRSelect:
    iUSelect = InputBox("Enter a Number to Select Action:" & vbCrLf & vbCrLf & _
        "   1 - RUN ALL" & vbCrLf & vbCrLf & _
        "   2 - Compile Data" & vbCrLf & vbCrLf & _
        "   3 - Finalize Report" & vbCrLf & vbCrLf & _
        "   0 - Cancel Operation" & vbCrLf, "Select Action")
        
'Check and Save Variables
    'Activate Sheet
        iwsCS.Activate
    'Fiscal Week
        Select Case iwsCS.Range("D2")
            Case 1 To 53        'Valid Entry
                'Continue
            Case Else           'Invalid Entry
                'Error Message
                    MsgBox ("ERROR! Invalid Fiscal Week!" & vbCrLf & vbCrLf & _
                        "Please make a valid entry!" & vbCrLf & vbCrLf & _
                        "Exiting Sub!")
                'Exit Sub
                    Exit Sub
        End Select
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
        
'Case select to set run
    Select Case iUSelect
        Case 1      'RUN All
            'Execute Call
                Call S2_Compile_Data
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Run All Complete!"
        Case 2      'Compile Data
            'Execute Call
                Call S2_Compile_Data
            'Set Completion Message
                iCMsg = "Data Compile Complete!"
        Case 3      'Finalize Report
            'Execute Call
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Report Finalized!"
        Case 0      'Cancel Operation
            'Set Cancellation message
                iCMsg = "Procedure Cancelled!"
        Case Else   'Error Handle
            'Error message
                MsgBox ("ERROR! Please make a valid selection!")
            'Error Handle
                GoTo iERRSelect
    End Select

'Finalize Report
    'Set Error Report Warning
        'Activate Sheet
            iwsDISP2.Activate
        'Item Count
            iErCt = Range("A" & Rows.Count).End(xlUp).Row - 1
    'Final View
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        If iErCt > 0 Then
            'Completion message With Error Report Warning
                MsgBox (iCMsg & vbCrLf & vbCrLf & _
                    "WARNING! " & iErCt & " items reported on error report!" & vbCrLf & vcbrlf)
        Else
            'Standard Completion Message
                MsgBox (iCMsg)
        End If

End Sub
Private Sub M4_Generate_Submission_Form()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Generates Distro Form
'=================================================================================================================================

'Save Variables
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
    'Day
        iDy = Day(Date + 1)
    'Month
        iMth = Month(Date + 1)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date + 1)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew = "Central - SKU Blocking Submission File - To Be Loaded-" & iDStr & ".xlsx"

'Activate Sheet
    iwsCS.Activate
    
Dim iwbSub As Workbook
Dim iwsSub As Worksheet
'Generage New sheet
    'Add New Workbook
        Workbooks.Add
        Set iwbSub = ActiveWorkbook
        Set iwsSub = iwbSub.ActiveSheet

'Generate List Sheet
    'Activate Workbook
        iwsSub.Activate
    'Change Sheet Name
        iwsSub.Name = "List"
    'Set List
        Range("A1") = "Block"
        Range("A2") = "Unblock"
    'Generate New List
        'Copy Data
            iwsCFT1.Activate
            Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Paste Data
            iwsSub.Activate
            Range("C1").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Convert To Numbers
            iwsSub.Activate
            Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(1, 1), TrailingMinusNumbers:=True

Dim iwsTSN As Worksheet
'Loop and Generate Sheets
    'Activate Sheet
        iwsCS.Activate
    'Loop Through OU List and Grab all West
        For Each iOU In Range("Q3:Q" & Range("Q" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsCS.Activate
            'Select and get row
                iOU.Select
                iOUR = iOU.Row
            'Save Data
                iNum = Range("O" & iOUR)        'MU
                iOUT = Range("Q" & iOUR)        'OU
                iLoc = Range("S" & iOUR)        'Location
                iSSTr = iNum & "-" & iLoc       'Sheet String
            'Check if OU is West
                Select Case iOUT
                    Case "Central"
                        'Activate Workbook
                            iwbSub.Activate
                        'Add Sheet
                            On Error Resume Next
                            Sheets.Add(After:=iwbSub.Sheets(iwbSub.Sheets.Count)).Name = iSSTr
                            Set iwsTSN = iwbSub.Sheets(iSSTr)
                        'Activate Sheet
                            iwsTSN.Activate
                        'Generate Headers
                            Range("A1") = "SKU"
                            Range("B1") = "Status"
                            Range("C1") = "Description"
                        'Generate List
                            With Range("B2:B500").Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsSub.Name & "'!$A$1:$A$2"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                        'Generate Formula for Description
                            iwsTSN.Activate
                            Range("C2") = "=IF(ISBLANK($A2)=TRUE,"""",XLOOKUP($A2," & iwsSub.Name & "!$C:$C," & iwsSub.Name & "!$D:$D,"""",0))"
                            Range("C2").AutoFill Destination:=Range("C2:C500")
                End Select
        Next iOU

'Save Book
    'Activate Workbook
        iwbSub.Activate
    'Hide List Sheet
        On Error Resume Next
        iwsSub.Visible = False
    'Save Copy
        iwbSub.SaveCopyAs iSPth & iwbNew
    'Close Submission Book No Save
        iwbSub.Close savechanges:=False

'Finalize Report
    'Activate Sheet
        iwsCS.Activate
    'Set Final View
        Range("A1").Select
    'Completion Message
        MsgBox ("Submission Form Generated!")
        
End Sub
Private Sub M5_Archive_SKUs()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 9 Jun 21

'Executes SKU Archival
'=================================================================================================================================

'Warning Message
    

'Loop to Archive Items based on Rules
    'Activate Sheet
        iwsDISP1.Activate
    'Loop Through SKUs
        For Each IArc In Range("A7:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDISP1.Activate
            'Select and Get Row
                IArc.Select
                iArcR = IArc.Row
            'Save Variables
                iODL = UCase(Range("C" & iArcR))                                                        'Delist Flag
                iStat = Range("D" & iArcR)                                                              'Status
                iOCt = Application.CountIf(iwsDISP1.Range("$E" & iArcR & ":$K" & iArcR & ""), "Open")   'Open Count
            'Initial Delist Check
                Select Case iODL
                    Case "X"            'Item Delisted
                        'Check Open Count
                            Select Case iOCt
                                Case "0"        'Move
                                    'Import
                                        'Copy
                                            iwsDISP1.Activate
                                            Range("A" & iArcR & ":K" & iArcR).Copy
                                        'Paste Data
                                            iwsDT2.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Set Date Stamp
                                            Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                    'Set Archive Flag
                                        iwsDISP1.Activate
                                        Range("C" & iArcR) = "ARCHIVED"
                                Case Else       'Still Open in Locations
                                    'No Action
                            End Select
                    Case Else           'Not On Delist
                        'Check Status
                            Select Case iStat
                                Case "LTO"      'LTO Status
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0                      'None Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else       'Some Locations Open
                                                'No Action
                                        End Select
                                Case "Long Term OOS", "", " ", 0        'Long Term Out of Stock and Blanks
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0      'All Closed
                                                'No Action
                                            Case 7     'All Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else   'Some location Open
                                                'No Action
                                        End Select
                            End Select
                        
                End Select
        Next IArc
    
'Remove Archived Items
    'Activate Sheet
        iwsDISP1.Activate
    'Loop and Delete Archived Rows
        'Set Initial Deletion Count
            iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
        'Delete Items
            Do Until iDelCt = 0
                'Get Row
                    iDelRw = Application.Match("ARCHIVED", iwsDISP1.Range("C:C"), 0)
                'Select and Delete Row
                    Range("C" & iDelRw).Select
                    Range("C" & iDelRw).EntireRow.Delete
                'Reset Deletion Count
                    iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
            Loop

'Check Archived SKUs for Items more than 90 days old
    'Activate Sheet
        iwsDT2.Activate
    'Insert Formula For Check
        Range("Y7") = "=IF(TODAY()-$L7<=90,""1-KEEP"",""2-DELETE"")"
        Range("Y7").AutoFill Destination:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Delete Items
        'Sort To Group Deletion Items Together
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        'Deletion Cycle
            'Set Initial deletion Count
                iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
            'Loop and Delete
                Do Until iDelCt = 0
                    'Select and Get Rows
                        'Start
                            iDRw1 = Application.Match("2-DELETE", iwsDT2.Range("Y:Y"), 0)
                        'End
                            If iDelCt > 1000 Then
                                iDRw2 = iDRw1 + 999
                            Else
                                iDRw2 = iDRw1 + (iDelCt - 1)
                            End If
                        'Select and Delete Selection
                            Range("Y" & iDRw1 & ":Y" & iDRw2).Select
                            Range("Y" & iDRw1 & ":Y" & iDRw2).EntireRow.Delete
                        'Set Initial deletion Count
                            iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
                Loop
        'Remove Identifiers
            Range("Y:Y").Delete
        'Reset Date Sort
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("L7:L" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:L" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    
'Finalize Report
    'Set View
        'Activate Sheet
            iwsDISP1.Activate
        'Set Selection
            Range("A1").Select
            Range("E7").Select
    'Completion message
        MsgBox ("SKU Archival Complete!")
            
End Sub
Private Sub S2_Compile_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")

'Refresh CRAFT
    'Activate Sheet
        iwsCFT1.Activate
    'Clear BIB Identity
        Columns("D:D").Delete
    'Refresh Data
        iwb.RefreshAll
    'Insert Identity Formula
        'Range("D1") = "=IF(IFERROR(SEARCH(""BIB"",$C1),0)>0,""BIB"","""")"
        'Range("D1").AutoFill Destination:=Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row)
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        'Application.CutCopyMode = False

'Correct Format of SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Trim Data
        'Insert Trim Formula
            Range("D2") = "=TRIM(SUBSTITUTE($A2,CHAR(160),CHAR(32)))"
        'Autofill and Copy Paste Results
            Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Remove Fixy
            Columns("D:D").Delete
    'Activate Sheet
        iwsDT1.Activate
        Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
    'Clear Blanks First
        'Initial Remove
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        'Final Check
            'Insert Space Check
                Range("D2") = "=IF(LEN(TRIM($A2))=0,""2-DELETE"",""1-KEEP"")"
            'Fill and Copy Paste Results
                Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            'Loop and Check if items need deletion
                'Set Initial Deletion Count
                    iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                'Loop and Remove Items
                    Do Until iDelCt = 0
                        'Get Row
                            iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                        'Select and Delete
                            Range("D" & iDelRw).Select
                            Range("D" & iDelRw).EntireRow.Delete
                        'Reset Deletion Count
                            iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                    Loop
            'Remove Identifier
                Columns("D:D").Delete
    'Generate Correction Formula
        Range("D2") = "=IFERROR(VALUE(TRIM($A2)),""ERROR"")"
    'Fill Data
        Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Error Handle
        If Application.IfError(Application.Match("ERROR", iwsDT1.Range("D:D"), 0), 0) > 0 Then
            'Error Message
                MsgBox ("ERROR! SKU " & iwsDT1.Range("A" & Application.Match("ERROR", iwsDT1.Range("D:D"), 0)) & _
                    " is not in number format!" & vbCrLf & vbCrLf & _
                    "Please correct and re run!" & vbCrLf & vbCrLf & _
                    "Exiting Sub!")
            'Exit sub
                Exit Sub
        End If
    'Import to SKU list and Remove Fix Column
        'Import Data
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Clear Fix Column
            Columns("D:D").Delete

'Execute Rules
    'Replicate Actions
        'Loop Through Replicate Actions Database
            'Activate Sheet
                iwsCS.Activate
            'Generate Temp Sheet
                'Remove Temp Sheet if Pre Existing
                    On Error Resume Next
                    iwb.Sheets("TEMP").Delete
                'Generate New Temp Sheet
                    Dim iwsTMP As Worksheet
                    Sheets.Add.Name = "TEMP"
                    Set iwsTMP = iwb.Sheets("TEMP")
                'Generate Headers
                    iwsTMP.Activate
                    Range("A1") = "SKU"
                    Range("B1") = "Status"
                    Range("C1") = "Plant"
            'Activate Sheet
                iwsCS.Activate
            'Execute Loop and Search
                For Each iRA In Range("M3:M" & Range("M" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsCS.Activate
                    'Select and Save Data
                        iRA.Select
                        iRAR = iRA.Row
                        iFP = Range("M" & iRAR)
                        iTP = Range("N" & iRAR)
                    'Execute Loop in Submitted SKUs
                        'Activate Sheet
                            iwsDT1.Activate
                        'Loop
                            For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Save Variables
                                    iCK.Select
                                    iCKR = iCK.Row
                                    iPlt = Range("C" & iCKR)
                                'Check if Replication Required
                                    If iPlt = iFP Then
                                        'Save Data
                                            iSKU = Range("A" & iCKR)
                                            iStat = Range("B" & iCKR)
                                        'Set Temp Row
                                            iwsTMP.Activate
                                            iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
                                        'Insert Data
                                            Range("A" & iTMPR) = iSKU
                                            Range("B" & iTMPR) = iStat
                                            Range("C" & iTMPR) = iTP
                                    End If
                            Next iCK
                Next iRA
            'Move Data Back to Data Sheet
                'Activate Sheet
                    iwsTMP.Activate
                'Check if Import Required
                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                        'Copy Data
                            iwsTMP.Activate
                            Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                        'Paste Data
                            iwsDT1.Activate
                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                            Application.CutCopyMode = False
                    End If
            'Delete Temp Sheet
                On Error Resume Next
                iwsTMP.Delete

'Execute Data Scrub
    'Reset Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Delete Data
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
        'Header Set
            Range("A1") = "SKU"
            Range("B1") = "Status"
            Range("C1") = "Plant"
            Range("D1") = "Error Reason"
    'Insert Identifiers
        'Activate Sheet
            iwsDT1.Activate
        'Insert ID
            Range("E2") = "=$A2&$C2"
            Range("F2") = "=$A2&$B2&$C2"
        'Autofill
            Range("E2:F2").AutoFill Destination:=Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
    'Remove Duplicates with Similar Status
        'Activate Sheet
            iwsDT1.Activate
            On Error Resume Next
            iwsDT1.Range("$A$1:$F$" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=6, Header:=xlYes
    'Check for Duplicates with Different Status
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Check Each item
            For Each iDDS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iDDS.Select
                    iDDSRw = iDDS.Row
                'Set Counts
                    iSPCt = Application.CountIfs(iwsDT1.Range("$E:$E"), iwsDT1.Range("$E" & iDDSRw))        'SKU & Plant
                    iSSPCt = Application.CountIfs(iwsDT1.Range("$F:$F"), iwsDT1.Range("$F" & iDDSRw))       'SKU, Status & Plant
                'Move to Error Report if Necessary
                    If iSPCt <> iSSPCt Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iDDSRw & ":C" & iDDSRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                Range("D" & iTDR) = "Duplicate with Different Statuses"
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iDDSRw) = "2-DELETE"
                    End If
            Next iDDS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove Columns
                Columns("E:F").Delete
    'Validate Status
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($B2,'" & iwsCS.Name & "'!$T$3:$T$4,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVS.Select
                        iVSRw = iVS.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVSRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVSRw & ":C" & iVSRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Status Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVSRw) = "2-DELETE"
                        End If
                Next iVS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Validate Plant
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$O$3:$O$41,0),0)+" & _
                "IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$N$3:$N$41,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVP.Select
                        iVPRw = iVP.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVPRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVPRw & ":C" & iVPRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Plant Number Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVPRw) = "2-DELETE"
                        End If
                Next iVP
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Check for Items to Exclude
        'Activate Sheet
            iwsDT1.Activate
        'Insert Formula
            Range("E2") = "=IF(IFERROR(MATCH($A2,'" & iwsCS.Name & "'!$AD:$AD,0),0)>0,""EXCL"","""")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Loop and Check Each item
            For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iVP.Select
                    iVPRw = iVP.Row
                'Move to Error Report if Necessary
                    If Range("E" & iVPRw) = "EXCL" Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iVPRw & ":C" & iVPRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                'Range("D" & iTDR) = "Unable to process BIB Items"
                                Range("D" & iTDR) = Application.XLookup(Range("$A" & iTDR), iwsCS.Range("$AD:$AD"), iwsCS.Range("$AE:$AE"), 0, 0)
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iVPRw) = "2-DELETE"
                    End If
            Next iVP
            
    'Format Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Set Widths
            Columns("A:C").ColumnWidth = 12
            Columns("D:D").ColumnWidth = 35
        'Set Borders
            With Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).Borders
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
    'Remove Items From Main Data Set
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Delete
            'Set Initial Deletion Count
                iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
            'Loop and Delete Items
                Do Until iDelCt = 0
                    'Get Row
                        iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                    'Select and Delete
                        Range("D" & iDelRw).Select
                        Range("D" & iDelRw).EntireRow.Delete
                    'Reset Initial Deletion Count
                        iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                Loop

'Loop Through Each SKU and set tracker
    'Activate Sheet
        iwsDT1.Activate
    'Loop
        For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDT1.Activate
            'Select and get Data
                iSKU.Select
                iSRw = iSKU.Row
            'Save data Sheet Variables
                'Activate Sheet
                    iwsDT1.Activate
                'Set Variables
                    iSKUN = Range("A" & iSRw)                           'SKU
                    iStat = Range("B" & iSRw)                           'Status
                    iPlnt = Range("C" & iSRw)                           'Plant
            'Set Tracker
                'Activate Sheet
                    iwsDISP1.Activate
                'Check if New Item - Add to List if Necessary if already entered find row
                    If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
                        'Set Working Row
                            iWRw = Range("A" & Rows.Count).End(xlUp).Row + 1
                        'Enter Info
                            Range("A" & iWRw) = iSKUN
                            Range("B" & iWRw) = Application.XLookup(Application.Text(iSKUN, 0), iwsCFT1.Range("A:A"), iwsCFT1.Range("B:B"), "N/A", 0)
                        'Generate Status List
                            With Range("D" & iWRw).Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsCS.Name & "'!$AA$3:$AA$5"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                    Else
                        'Set Working Row
                            iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
                    End If
            'Set Column/Range Variable
                'Working Column
                    iWCol = Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0)
                    iWCol = Left(Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1), _
                        Application.Search("$", Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1)) - 1)
                'Working Range
                    Dim iWRng As Range
                    Set iWRng = Range(iWCol & iWRw)
                    iWRng.Select
            'Set Block/Unblock
                Select Case iStat
                    Case "Block"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Week
                            iWRng = "Block"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                    Case "Unblock"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Open
                            iWRng = "Unblock"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                End Select
        Next iSKU

'Clean Sheet
    'Get End of DataSet
        'Activate Sheet
            iwsDISP1.Activate
        'Final Pull and Variable Set
            iECol = Rows("6:6").End(xlToRight).Column
            iECol = Left(Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1), _
                Application.Search("$", Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1)) - 1)
    'Double Check Descriptions
        'Activate Sheet
            iwsDISP1.Activate
        'Loop and Validate Data
            For Each iDCD In Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row)
                'Select and Get Row
                    iDCD.Select
                    iDCDRw = iDCD.Row
                'Check if New Description Required
                    If Range("B" & iDCDRw) = "N/A" Then
                        Range("B" & iDCDRw) = Application.XLookup(Application.Text(Range("A" & iDCDRw), 0), _
                            iwsCFT1.Range("A:A"), _
                            iwsCFT1.Range("B:B"), _
                            "N/A", 0)
                    End If
            Next iDCD
    'Fill Blanks
        'Activate Sheet
            iwsDISP1.Activate
        'Fill data if Necessary
            If Application.CountBlank(iwsDISP1.Range("$E$7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row)) > 0 Then
                'Select Blanks
                    On Error Resume Next
                    Range("$E7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Select
                'Set Formatting
                    'Set Text
                        Selection = "Open"
                    'Highlighting
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 5296274
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    'Font
                        With Selection.Font
                            .ThemeColor = xlThemeColorLight1
                            .TintAndShade = 0
                        End With
            End If

'Final Formatting Cleanup
    'Activate Sheet
        iwsDISP1.Activate
    'Set Borders
        With Range("A7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    'Font Size and Format
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Font.Size = 10
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlLeft
    'Set Grey Details Highlighting
        With Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.149998474074526
            .PatternTintAndShade = 0
        End With

End Sub
Private Sub S3_Finalize_Report()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")
    'Save Path
        iSPth = iwsCS.Range("D4")
    'Email Confirmation - Processing
        iEMConf = iwsCS.Range("D6")
    'Email Confirmation - General Distr
        iEMConf1 = iwsCS.Range("D8")
    'Day
        iDy = Day(Date)
    'Month
        iMth = Month(Date)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew1 = "Central - SKU Blocking Tracker - " & iDStr & ".xlsm"
        iwbNew2 = "Central - SKU Blocking Data - " & iDStr & ".xlsm"
    'Item error Count - Save Table If Necessary
        'Activate Sheet
            iwsDISP2.Activate
        'Set Count
            iErrCt = Range("A" & Rows.Count).End(xlUp).Row - 1
        'Set Range
            Set iDtaRng = iwsDISP2.Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row + 1)
    
'Generate Date on Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
        Range("C1") = "Current Week " & iFWk

Dim iwbFmt As Workbook
Dim iwsVis As Worksheet
'Generate Copies
    'Tracker
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew1
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew1
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDISP1.Name).Activate
                'Set View
                    Range("A1").Select
                    Range("E7").Select
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDISP1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True
    'Submission Data
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew2
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew2
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDT1.Name).Activate
                'Set View
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDT1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True

'Distribute to Processing if Option Selected
    If iEMConf = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("K" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMTo = iEMTo & Range("K" & iEMRw) & "; "
                Next iEM
            Else
                iEMTo = ""
            End If
        'Generate CC Email
            If Range("L" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("L3:L" & Range("L" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMCC = iEMCC & Range("L" & iEMRw) & "; "
                Next iEM
            Else
                iEMCC = ""
            End If
        'Generate Subject Line
            iSubj = "Central - Master Data Delist Tracker - " & iDStr
        'Generate Body
            iMsg = "Hello Everyone," & vbCrLf & vbCrLf & _
                "Attached is the delist tracker for " & iDStr & "." & vbCrLf & vbCrLf & _
                "Thanks," & vbCrLf
        'Generate Email
        Dim olApp As Object
        Dim olMail As Object
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMTo
                    .CC = iEMCC
                    .Subject = iSubj
                    .body = iMsg
                    .Attachments.Add iSPth & iwbNew2
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If

'Distribute to General Option Selected
    If iEMConf1 = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("I" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGTo = iEMGTo & Range("I" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGTo = ""
            End If
        'Generate CC Email
            If Range("J" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("J3:J" & Range("J" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGCC = iEMGCC & Range("J" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGCC = ""
            End If
        'Generate Subject Line
            iSubjG = "Central - Delist Tracker - " & iDStr
        'Generate Body - Depends on If Error items Found
            If iErrCt = 0 Then
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Thanks," & "<br>"
            Else
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Items were not loaded due to errors detected" & "<br>" & _
                    "Please review and resubmit the following items:" & "<br>" & "<br>" & _
                    RangetoHTML(iDtaRng) & "<br>" & "<br>" & "Thanks," & "<br>"
            End If
        'Generate Email
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMGTo
                    .CC = iEMGCC
                    .Subject = iSubjG
                    .HTMLbody = iMsgG
                    .Attachments.Add iSPth & iwbNew1
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If
        
End Sub
Private Sub Reconcile()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Week
iFWk = iwsCS.Range("D2")

'Execute Reset Call
Call M1_Reset_Sheet

Dim iwbSAP As Workbook
Dim iwsSAP As Worksheet
'Select File to Load
'Set Pathway to Open to
'ChDir ActiveWorkbook.Path
'Run Dialog with Cancellation Error Handling
cancel = Application.GetOpenFilename _
(Title:="Select Central OU Reconcile File to Load")
If cancel = False Then
MsgBox ("Import Session Ended")
Exit Sub
End If
With Workbooks.Open(cancel)
End With
'Set variable Name
Set iwbSAP = ActiveWorkbook
Set iwsSAP = iwbSAP.ActiveSheet

Application.ScreenUpdating = False

Dim iwsTMP1 As Worksheet
'Generate Temp Sheet
'Activate Sheet
iwb.Activate
'Remove Temp Sheet if already exists
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Sheet
Sheets.Add.Name = "TEMP"
Set iwsTMP1 = iwb.Sheets("TEMP")

'Import Data To Main Sheet
'Copy Data
iwsSAP.Activate
Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsTMP1.Activate
Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Close SAP workbook no save
iwbSAP.Close savechanges:=False

'Execute format and clean
'Clean to just relevant Plants and SKUs
'Activate Sheet
iwsTMP1.Activate
'Text to columns material
Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Formula Insert and Fill
Range("G2") = "=IF(AND(" & _
"COUNTIFS('" & iwsDISP1.Name & "'!$6:$6,$C2)>0," & _
"COUNTIFS('" & iwsDISP1.Name & "'!$A:$A,$D2)>0)," & _
"""1-KEEP"",""2-DELETE"")"
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Sort To Group Items for deletion
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:G" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("G:G"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("G" & iSRw & ":G" & iERw).Select
Range("G" & iSRw & ":G" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0), 0)
Loop
'Remove Identifier
Columns("G:G").Delete
'Duplicates Scrub
'Activate sheet
iwsTMP1.Activate
'Generate Duplicates Identifier
Range("G1") = "Unique ID"
Range("H1") = "Duplicates Count"
'Insert Formulas
Range("G2") = "=$C2&$D2"
Range("H2") = "=IF(COUNTIFS($G:$G,$G2)>1,""2-DUP"","""")"
Range("G2:H2").AutoFill Destination:=Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Duplicates Correction if detected
If Application.CountIfs(iwsTMP1.Range("$H:$H"), "2-DUP") > 1 Then
'Execute Scrub
'Sort data for Scrub
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Flag Items for Deletion
'Activate Sheet
iwsTMP1.Activate
'Loop and Execute Ident
For Each iDupCt In Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row)
'Select and Get row
iDupCt.Select
iDCRw = iDupCt.Row
'Save Start and End Rows
iUIDS = Range("G" & iDCRw)
iDRS = Application.Match(iUIDS, iwsTMP1.Range("G:G"), 0)
iDRE = iDRS + (Application.CountIfs(iwsTMP1.Range("$G:$G"), iUIDS) - 1)
'Enter Formula
If Application.Rank(iwsTMP1.Range("$E" & iDCRw), iwsTMP1.Range("$E" & iDRS & ":$E" & iDRE), 0) > 1 Then
Range("H" & iDCRw) = "2-DELETE"
Else
Range("H" & iDCRw) = "1-KEEP"
End If
Next iDupCt
'Sort and Delete all Items flagged for deletion
'Activate Sheet
iwsTMP1.Activate
'Sort Items for Deletion Groups
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("H:H"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("H" & iSRw & ":H" & iERw).Select
Range("H" & iSRw & ":H" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0), 0)
Loop
End If
'Identify Status
'Reset Columns
Columns("G:H").Delete
Range("G1") = "Status"
'Generate Formula
Range("G2") = "=IF(YEAR($F2)=9999,""Unblock"",""Block"")"
Range("G2") = "=IF($F2 "
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Resort Data
Columns("C:C").Cut
Columns("A:A").Insert
Columns("G:G").Cut
Columns("A:A").Insert
Columns("E:E").Cut
Columns("A:A").Insert
'Import data to Submitted SKUs Sheet
iwsTMP1.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
iwsDT1.Activate
Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete Temp Sheet
iwsTMP1.Delete

'Loop Through Each SKU and set tracker
'Replicate Actions
'Loop Through Replicate Actions Database
'Activate Sheet
iwsCS.Activate
'Generate Temp Sheet
'Remove Temp Sheet if Pre Existing
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Temp Sheet
Dim iwsTMP As Worksheet
Sheets.Add.Name = "TEMP"
Set iwsTMP = iwb.Sheets("TEMP")
'Generate Headers
iwsTMP.Activate
Range("A1") = "SKU"
Range("B1") = "Status"
Range("C1") = "Plant"
'Activate Sheet
iwsCS.Activate
'Execute Loop and Search
For Each iRA In Range("AB3:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsCS.Activate
'Select and Save Data
iRA.Select
iRAR = iRA.Row
iFP = Range("AB" & iRAR)
iTP = Range("AC" & iRAR)
'Execute Loop in Submitted SKUs
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Save Variables
iCK.Select
iCKR = iCK.Row
iPlt = Range("C" & iCKR)
'Check if Replication Required
If iPlt = iFP Then
'Save Data
iSKU = Range("A" & iCKR)
iStat = Range("B" & iCKR)
'Set Temp Row
iwsTMP.Activate
iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
'Insert Data
Range("A" & iTMPR) = iSKU
Range("B" & iTMPR) = iStat
Range("C" & iTMPR) = iTP
End If
Next iCK
Next iRA
'Move Data Back to Data Sheet
'Activate Sheet
iwsTMP.Activate
'Check if Import Required
If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
'Copy Data
iwsTMP.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsDT1.Activate
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
'Delete Temp Sheet
On Error Resume Next
iwsTMP.Delete
'Update Tracker
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Select and get Data
iSKU.Select
iSRw = iSKU.Row
'Save data Sheet Variables
'Activate Sheet
iwsDT1.Activate
'Set Variables
iSKUN = Range("A" & iSRw) 'SKU
iStat = Range("B" & iSRw) 'Status
iPlnt = Range("C" & iSRw) 'Plant
'Set Tracker
'Activate Sheet
iwsDISP1.Activate
'Check if New Item - Skip
If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
GoTo iSkipProcess
Else
'Set Working Row
iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
End If
'Set Column/Range Variable
'Working Column
'Get Working Column
iWCol = Application.IfError(Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0), 0)
'Error Handler
If iWCol = 0 Then
GoTo iSkipProcess
Else
'Convert Column Number to Letter
iWCol = Left(Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1), _
Application.Search("$", Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1)) - 1)
End If
'Working Range
Dim iWRng As Range
Set iWRng = Range(iWCol & iWRw)
iWRng.Select
'Set Block/Unblock
Select Case iStat
Case "Block"
'Activate Sheet
iwsDISP1.Activate
'Set Week
iWRng = "Block"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
Case "Unblock"
'Activate Sheet
iwsDISP1.Activate
'Set Open
iWRng = "Unblock"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
End Select
iSkipProcess:
Next iSKU

'Completion Message
Application.ScreenUpdating = False
MsgBox ("Mass System Reconciliation Complete!")

End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
    'Create Temp File
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                             "align=left x:publishsource=")
    'Close TempWB
        TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
        Kill TempFile
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
End Function

Private Sub M1_Reset_Sheet()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 12 May 21

'Resets All Sheets
'=================================================================================================================================

'Confirmation
    'User Input
        iRConf = MsgBox("This will remove submitted SKUs" & vbCrLf & vbCrLf & _
            "Proceed?", vbYesNo, "Reset Confirmation")
    'If no
        If iRConf = vbNo Then
            Exit Sub
        End If

'Reset Data SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Delete All
        On Error Resume Next
        Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
    'Set Dropdown for Status
        'Block/Unblock
            With iwsDT1.Range("B2:B1000").Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="='" & iwsCS.Name & "'!$T$3:$T$4"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

'Reset Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
    'Set Font
        With iwsDISP1.Range("E7:W" & Range("A" & Rows.Count).End(xlUp).Row).Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
        End With
    'Find Unblock from previous run and set to open
        For Each iColCK In Range("E6:W6")
            'Select and Get Column Unblock
                iColCK.Select
                iColFmt = Left(Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1), _
                    Application.Search("$", Right(Cells(1, iColCK.Column).Address, _
                    Len(Cells(1, iColCK.Column).Address) - 1)) - 1)
            'Loop and Set Unblock to Open
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Open"
                        'Set Green Format
                            With Range(iColFmt & iDelCt).Interior
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                                .Color = 5296274
                                .TintAndShade = 0
                                .PatternTintAndShade = 0
                            End With
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Unblock", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
            'Loop and Set Block to Closed
                'Set Unblock Row
                    iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                'Do Until all reset
                    Do Until iDelCt = 0
                        'Set Text
                            Range(iColFmt & iDelCt).Select
                            Range(iColFmt & iDelCt) = "Closed"
                        'Reset Unblock Row
                            iDelCt = Application.IfError(Application.Match("Block", iwsDISP1.Range(iColFmt & ":" & iColFmt), 0), 0)
                    Loop
        Next iColCK

'Reset Error Report
    'Activate Sheet
        iwsDISP2.Activate
    'Remove All Data
        On Error Resume Next
        Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    'Reset Headers
        Range("A1") = "SKU"
        Range("B1") = "Status"
        Range("C1") = "Plant"
        Range("D1") = "Error Reason"
        
'Finalize Report
    'Set Final Views
        iwsDISP1.Activate
        Range("A1").Select
        iwsDT1.Activate
        Range("A1").Select
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        MsgBox ("Sheets Reset!")

End Sub
Private Sub M2_Load_Submission_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Loads Data
'=================================================================================================================================

Dim iwbSub As Workbook
'Select File to Load
    'Set Pathway to Open to
        'ChDir ActiveWorkbook.Path,
    'Run Dialog with Cancellation Error Handling
        cancel = Application.GetOpenFilename _
        (Title:="Select Central OU Submission Form to Load")
        If cancel = False Then
            MsgBox ("Import Session Ended")
            Exit Sub
        End If
        With Workbooks.Open(cancel)
        End With
    'Set variable Name
        Set iwbSub = ActiveWorkbook

Dim iwsImp As Worksheet
'Loop Through All Worksheets
    'Activate Workbook
        iwbSub.Activate
    'Loop and Import Data
        For Each iwsImp In Worksheets
            'Activate Workbook
                iwbSub.Activate
            'Unhide workbook if necessary
                On Error Resume Next
                iwsImp.Visible = True
            'Activate Sheet
                iwsImp.Activate
            'Check Sheet Name - Save if is registered site
                'Get Initial Sheet Name
                    iLoc = Left(iwsImp.Name, 4)
                'Skip if Sheet Name is List
                    If iLoc = "List" Then
                        GoTo iFunctSkip
                    End If
                'Execute Test
                    'Activate Sheet
                        iwsImp.Activate
                    'Check Database
                        iLocTest = Application.IfError(Application.Match(iLoc, iwsCS.Range("$O:$O"), 0), 0) + _
                            Application.IfError(Application.Match(iLoc, iwsCS.Range("$N:$N"), 0), 0)
                    'Actions Test
                        'If Valid - Import Data
                            If iLocTest > 0 Then
                                'Test If Data Exists to Import
                                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                                        'Copy Data
                                            iwsImp.Activate
                                            Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                                        'Paste Data
                                            iwsDT1.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Fill Site Number
                                            Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1 & _
                                                ":C" & Range("A" & Rows.Count).End(xlUp).Row) = iLoc
                                    Else
                                        GoTo iFunctSkip
                                    End If
                        'If Not Valid Set Warning
                            Else
                                'Generate Error message
                                    MsgBox ("WARNING! Invalid sheet name detected!" & vbCrLf & vbCrLf & _
                                        "Please validate:" & vbCrLf & vbCrLf & _
                                        iwsImp.Name)
                                'Error handle
                                    GoTo iFunctSkip
                            End If
iFunctSkip:
        Next iwsImp

'Close Workbook with no Saving
    iwbSub.Close savechanges:=False

'Finalize Report
    'Set Final View on Data
        iwsDT1.Activate
        Range("A1").Select
    'Set Final View
        iwsCS.Activate
        Range("A1").Activate
    'Completion message
        MsgBox ("Submission Data Loaded!")

End Sub
Private Sub M3_Compile_Report()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'User Option Select
iERRSelect:
    iUSelect = InputBox("Enter a Number to Select Action:" & vbCrLf & vbCrLf & _
        "   1 - RUN ALL" & vbCrLf & vbCrLf & _
        "   2 - Compile Data" & vbCrLf & vbCrLf & _
        "   3 - Finalize Report" & vbCrLf & vbCrLf & _
        "   0 - Cancel Operation" & vbCrLf, "Select Action")
        
'Check and Save Variables
    'Activate Sheet
        iwsCS.Activate
    'Fiscal Week
        Select Case iwsCS.Range("D2")
            Case 1 To 53        'Valid Entry
                'Continue
            Case Else           'Invalid Entry
                'Error Message
                    MsgBox ("ERROR! Invalid Fiscal Week!" & vbCrLf & vbCrLf & _
                        "Please make a valid entry!" & vbCrLf & vbCrLf & _
                        "Exiting Sub!")
                'Exit Sub
                    Exit Sub
        End Select
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
        
'Case select to set run
    Select Case iUSelect
        Case 1      'RUN All
            'Execute Call
                Call S2_Compile_Data
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Run All Complete!"
        Case 2      'Compile Data
            'Execute Call
                Call S2_Compile_Data
            'Set Completion Message
                iCMsg = "Data Compile Complete!"
        Case 3      'Finalize Report
            'Execute Call
                Call S3_Finalize_Report
            'Set Completion Message
                iCMsg = "Report Finalized!"
        Case 0      'Cancel Operation
            'Set Cancellation message
                iCMsg = "Procedure Cancelled!"
        Case Else   'Error Handle
            'Error message
                MsgBox ("ERROR! Please make a valid selection!")
            'Error Handle
                GoTo iERRSelect
    End Select

'Finalize Report
    'Set Error Report Warning
        'Activate Sheet
            iwsDISP2.Activate
        'Item Count
            iErCt = Range("A" & Rows.Count).End(xlUp).Row - 1
    'Final View
        iwsCS.Activate
        Range("A1").Select
    'Completion message
        If iErCt > 0 Then
            'Completion message With Error Report Warning
                MsgBox (iCMsg & vbCrLf & vbCrLf & _
                    "WARNING! " & iErCt & " items reported on error report!" & vbCrLf & vcbrlf)
        Else
            'Standard Completion Message
                MsgBox (iCMsg)
        End If

End Sub
Private Sub M4_Generate_Submission_Form()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 11 Jun 21

'Generates Distro Form
'=================================================================================================================================

'Save Variables
    'Save Path
        iSPth = iwsCS.Range("D4")
        If Right(iSPth, 1) <> "\" Then
            iwsCS.Range("D4") = iSPth & "\"
            iSPth = iwsCS.Range("D4")
        End If
    'Day
        iDy = Day(Date + 1)
    'Month
        iMth = Month(Date + 1)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date + 1)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew = "Central - SKU Blocking Submission File - To Be Loaded-" & iDStr & ".xlsx"

'Activate Sheet
    iwsCS.Activate
    
Dim iwbSub As Workbook
Dim iwsSub As Worksheet
'Generage New sheet
    'Add New Workbook
        Workbooks.Add
        Set iwbSub = ActiveWorkbook
        Set iwsSub = iwbSub.ActiveSheet

'Generate List Sheet
    'Activate Workbook
        iwsSub.Activate
    'Change Sheet Name
        iwsSub.Name = "List"
    'Set List
        Range("A1") = "Block"
        Range("A2") = "Unblock"
    'Generate New List
        'Copy Data
            iwsCFT1.Activate
            Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Paste Data
            iwsSub.Activate
            Range("C1").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Convert To Numbers
            iwsSub.Activate
            Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(1, 1), TrailingMinusNumbers:=True

Dim iwsTSN As Worksheet
'Loop and Generate Sheets
    'Activate Sheet
        iwsCS.Activate
    'Loop Through OU List and Grab all West
        For Each iOU In Range("Q3:Q" & Range("Q" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsCS.Activate
            'Select and get row
                iOU.Select
                iOUR = iOU.Row
            'Save Data
                iNum = Range("O" & iOUR)        'MU
                iOUT = Range("Q" & iOUR)        'OU
                iLoc = Range("S" & iOUR)        'Location
                iSSTr = iNum & "-" & iLoc       'Sheet String
            'Check if OU is West
                Select Case iOUT
                    Case "Central"
                        'Activate Workbook
                            iwbSub.Activate
                        'Add Sheet
                            On Error Resume Next
                            Sheets.Add(After:=iwbSub.Sheets(iwbSub.Sheets.Count)).Name = iSSTr
                            Set iwsTSN = iwbSub.Sheets(iSSTr)
                        'Activate Sheet
                            iwsTSN.Activate
                        'Generate Headers
                            Range("A1") = "SKU"
                            Range("B1") = "Status"
                            Range("C1") = "Description"
                        'Generate List
                            With Range("B2:B500").Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsSub.Name & "'!$A$1:$A$2"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                        'Generate Formula for Description
                            iwsTSN.Activate
                            Range("C2") = "=IF(ISBLANK($A2)=TRUE,"""",XLOOKUP($A2," & iwsSub.Name & "!$C:$C," & iwsSub.Name & "!$D:$D,"""",0))"
                            Range("C2").AutoFill Destination:=Range("C2:C500")
                End Select
        Next iOU

'Save Book
    'Activate Workbook
        iwbSub.Activate
    'Hide List Sheet
        On Error Resume Next
        iwsSub.Visible = False
    'Save Copy
        iwbSub.SaveCopyAs iSPth & iwbNew
    'Close Submission Book No Save
        iwbSub.Close savechanges:=False

'Finalize Report
    'Activate Sheet
        iwsCS.Activate
    'Set Final View
        Range("A1").Select
    'Completion Message
        MsgBox ("Submission Form Generated!")
        
End Sub
Private Sub M5_Archive_SKUs()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 9 Jun 21

'Executes SKU Archival
'=================================================================================================================================

'Warning Message
    

'Loop to Archive Items based on Rules
    'Activate Sheet
        iwsDISP1.Activate
    'Loop Through SKUs
        For Each IArc In Range("A7:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDISP1.Activate
            'Select and Get Row
                IArc.Select
                iArcR = IArc.Row
            'Save Variables
                iODL = UCase(Range("C" & iArcR))                                                        'Delist Flag
                iStat = Range("D" & iArcR)                                                              'Status
                iOCt = Application.CountIf(iwsDISP1.Range("$E" & iArcR & ":$K" & iArcR & ""), "Open")   'Open Count
            'Initial Delist Check
                Select Case iODL
                    Case "X"            'Item Delisted
                        'Check Open Count
                            Select Case iOCt
                                Case "0"        'Move
                                    'Import
                                        'Copy
                                            iwsDISP1.Activate
                                            Range("A" & iArcR & ":K" & iArcR).Copy
                                        'Paste Data
                                            iwsDT2.Activate
                                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                            Application.CutCopyMode = False
                                        'Set Date Stamp
                                            Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                    'Set Archive Flag
                                        iwsDISP1.Activate
                                        Range("C" & iArcR) = "ARCHIVED"
                                Case Else       'Still Open in Locations
                                    'No Action
                            End Select
                    Case Else           'Not On Delist
                        'Check Status
                            Select Case iStat
                                Case "LTO"      'LTO Status
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0                      'None Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else       'Some Locations Open
                                                'No Action
                                        End Select
                                Case "Long Term OOS", "", " ", 0        'Long Term Out of Stock and Blanks
                                    'Check Open Count
                                        Select Case iOCt
                                            Case 0      'All Closed
                                                'No Action
                                            Case 7     'All Open
                                                'Import
                                                    'Copy
                                                        iwsDISP1.Activate
                                                        Range("A" & iArcR & ":K" & iArcR).Copy
                                                    'Paste Data
                                                        iwsDT2.Activate
                                                        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                                                        Application.CutCopyMode = False
                                                    'Set Date Stamp
                                                        Range("L" & Range("A" & Rows.Count).End(xlUp).Row) = Date
                                                'Set Archive Flag
                                                    iwsDISP1.Activate
                                                    Range("C" & iArcR) = "ARCHIVED"
                                            Case Else   'Some location Open
                                                'No Action
                                        End Select
                            End Select
                        
                End Select
        Next IArc
    
'Remove Archived Items
    'Activate Sheet
        iwsDISP1.Activate
    'Loop and Delete Archived Rows
        'Set Initial Deletion Count
            iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
        'Delete Items
            Do Until iDelCt = 0
                'Get Row
                    iDelRw = Application.Match("ARCHIVED", iwsDISP1.Range("C:C"), 0)
                'Select and Delete Row
                    Range("C" & iDelRw).Select
                    Range("C" & iDelRw).EntireRow.Delete
                'Reset Deletion Count
                    iDelCt = Application.CountIfs(iwsDISP1.Range("C:C"), "ARCHIVED")
            Loop

'Check Archived SKUs for Items more than 90 days old
    'Activate Sheet
        iwsDT2.Activate
    'Insert Formula For Check
        Range("Y7") = "=IF(TODAY()-$L7<=90,""1-KEEP"",""2-DELETE"")"
        Range("Y7").AutoFill Destination:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Delete Items
        'Sort To Group Deletion Items Together
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("Y7:Y" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:Y" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        'Deletion Cycle
            'Set Initial deletion Count
                iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
            'Loop and Delete
                Do Until iDelCt = 0
                    'Select and Get Rows
                        'Start
                            iDRw1 = Application.Match("2-DELETE", iwsDT2.Range("Y:Y"), 0)
                        'End
                            If iDelCt > 1000 Then
                                iDRw2 = iDRw1 + 999
                            Else
                                iDRw2 = iDRw1 + (iDelCt - 1)
                            End If
                        'Select and Delete Selection
                            Range("Y" & iDRw1 & ":Y" & iDRw2).Select
                            Range("Y" & iDRw1 & ":Y" & iDRw2).EntireRow.Delete
                        'Set Initial deletion Count
                            iDelCt = Application.CountIfs(iwsDT2.Range("$Y:$Y"), "2-DELETE")
                Loop
        'Remove Identifiers
            Range("Y:Y").Delete
        'Reset Date Sort
            iwsDT2.Sort.SortFields.Clear
            iwsDT2.Sort.SortFields.Add2 _
                Key:=Range("L7:L" & Range("A" & Rows.Count).End(xlUp).Row), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            With iwsDT2.Sort
                .SetRange Range("A7:L" & Range("A" & Rows.Count).End(xlUp).Row)
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    
'Finalize Report
    'Set View
        'Activate Sheet
            iwsDISP1.Activate
        'Set Selection
            Range("A1").Select
            Range("E7").Select
    'Completion message
        MsgBox ("SKU Archival Complete!")
            
End Sub
Private Sub S2_Compile_Data()
Application.DisplayAlerts = False

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Compiles Data
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")

'Refresh CRAFT
    'Activate Sheet
        iwsCFT1.Activate
    'Clear BIB Identity
        Columns("D:D").Delete
    'Refresh Data
        iwb.RefreshAll
    'Insert Identity Formula
        'Range("D1") = "=IF(IFERROR(SEARCH(""BIB"",$C1),0)>0,""BIB"","""")"
        'Range("D1").AutoFill Destination:=Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row)
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        'Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        'Application.CutCopyMode = False

'Correct Format of SKUs
    'Activate Sheet
        iwsDT1.Activate
    'Trim Data
        'Insert Trim Formula
            Range("D2") = "=TRIM(SUBSTITUTE($A2,CHAR(160),CHAR(32)))"
        'Autofill and Copy Paste Results
            Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Remove Fixy
            Columns("D:D").Delete
    'Activate Sheet
        iwsDT1.Activate
        Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
    'Clear Blanks First
        'Initial Remove
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        'Final Check
            'Insert Space Check
                Range("D2") = "=IF(LEN(TRIM($A2))=0,""2-DELETE"",""1-KEEP"")"
            'Fill and Copy Paste Results
                Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            'Loop and Check if items need deletion
                'Set Initial Deletion Count
                    iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                'Loop and Remove Items
                    Do Until iDelCt = 0
                        'Get Row
                            iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                        'Select and Delete
                            Range("D" & iDelRw).Select
                            Range("D" & iDelRw).EntireRow.Delete
                        'Reset Deletion Count
                            iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                    Loop
            'Remove Identifier
                Columns("D:D").Delete
    'Generate Correction Formula
        Range("D2") = "=IFERROR(VALUE(TRIM($A2)),""ERROR"")"
    'Fill Data
        Range("D2").AutoFill Destination:=Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    'Error Handle
        If Application.IfError(Application.Match("ERROR", iwsDT1.Range("D:D"), 0), 0) > 0 Then
            'Error Message
                MsgBox ("ERROR! SKU " & iwsDT1.Range("A" & Application.Match("ERROR", iwsDT1.Range("D:D"), 0)) & _
                    " is not in number format!" & vbCrLf & vbCrLf & _
                    "Please correct and re run!" & vbCrLf & vbCrLf & _
                    "Exiting Sub!")
            'Exit sub
                Exit Sub
        End If
    'Import to SKU list and Remove Fix Column
        'Import Data
            Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("A2").PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Clear Fix Column
            Columns("D:D").Delete

'Execute Rules
    'Replicate Actions
        'Loop Through Replicate Actions Database
            'Activate Sheet
                iwsCS.Activate
            'Generate Temp Sheet
                'Remove Temp Sheet if Pre Existing
                    On Error Resume Next
                    iwb.Sheets("TEMP").Delete
                'Generate New Temp Sheet
                    Dim iwsTMP As Worksheet
                    Sheets.Add.Name = "TEMP"
                    Set iwsTMP = iwb.Sheets("TEMP")
                'Generate Headers
                    iwsTMP.Activate
                    Range("A1") = "SKU"
                    Range("B1") = "Status"
                    Range("C1") = "Plant"
            'Activate Sheet
                iwsCS.Activate
            'Execute Loop and Search
                For Each iRA In Range("M3:M" & Range("M" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsCS.Activate
                    'Select and Save Data
                        iRA.Select
                        iRAR = iRA.Row
                        iFP = Range("M" & iRAR)
                        iTP = Range("N" & iRAR)
                    'Execute Loop in Submitted SKUs
                        'Activate Sheet
                            iwsDT1.Activate
                        'Loop
                            For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Save Variables
                                    iCK.Select
                                    iCKR = iCK.Row
                                    iPlt = Range("C" & iCKR)
                                'Check if Replication Required
                                    If iPlt = iFP Then
                                        'Save Data
                                            iSKU = Range("A" & iCKR)
                                            iStat = Range("B" & iCKR)
                                        'Set Temp Row
                                            iwsTMP.Activate
                                            iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
                                        'Insert Data
                                            Range("A" & iTMPR) = iSKU
                                            Range("B" & iTMPR) = iStat
                                            Range("C" & iTMPR) = iTP
                                    End If
                            Next iCK
                Next iRA
            'Move Data Back to Data Sheet
                'Activate Sheet
                    iwsTMP.Activate
                'Check if Import Required
                    If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
                        'Copy Data
                            iwsTMP.Activate
                            Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
                        'Paste Data
                            iwsDT1.Activate
                            Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
                            Application.CutCopyMode = False
                    End If
            'Delete Temp Sheet
                On Error Resume Next
                iwsTMP.Delete

'Execute Data Scrub
    'Reset Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Delete Data
            On Error Resume Next
            Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
        'Header Set
            Range("A1") = "SKU"
            Range("B1") = "Status"
            Range("C1") = "Plant"
            Range("D1") = "Error Reason"
    'Insert Identifiers
        'Activate Sheet
            iwsDT1.Activate
        'Insert ID
            Range("E2") = "=$A2&$C2"
            Range("F2") = "=$A2&$B2&$C2"
        'Autofill
            Range("E2:F2").AutoFill Destination:=Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:F" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
    'Remove Duplicates with Similar Status
        'Activate Sheet
            iwsDT1.Activate
            On Error Resume Next
            iwsDT1.Range("$A$1:$F$" & Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=6, Header:=xlYes
    'Check for Duplicates with Different Status
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Check Each item
            For Each iDDS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iDDS.Select
                    iDDSRw = iDDS.Row
                'Set Counts
                    iSPCt = Application.CountIfs(iwsDT1.Range("$E:$E"), iwsDT1.Range("$E" & iDDSRw))        'SKU & Plant
                    iSSPCt = Application.CountIfs(iwsDT1.Range("$F:$F"), iwsDT1.Range("$F" & iDDSRw))       'SKU, Status & Plant
                'Move to Error Report if Necessary
                    If iSPCt <> iSSPCt Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iDDSRw & ":C" & iDDSRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                Range("D" & iTDR) = "Duplicate with Different Statuses"
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iDDSRw) = "2-DELETE"
                    End If
            Next iDDS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove Columns
                Columns("E:F").Delete
    'Validate Status
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($B2,'" & iwsCS.Name & "'!$T$3:$T$4,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVS In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVS.Select
                        iVSRw = iVS.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVSRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVSRw & ":C" & iVSRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Status Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVSRw) = "2-DELETE"
                        End If
                Next iVS
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Validate Plant
        'Activate Sheet
            iwsDT1.Activate
        'Enter Validation Identifier
            Range("E2") = "=IF(IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$O$3:$O$41,0),0)+" & _
                "IFERROR(MATCH($C2,'" & iwsCS.Name & "'!$N$3:$N$41,0),0)>0,"""",""ERROR"")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:D" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Move to Error Report if Necessary
            'Loop and Check Each item
                For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                    'Activate Sheet
                        iwsDT1.Activate
                    'Select and Get Row
                        iVP.Select
                        iVPRw = iVP.Row
                    'Move to Error Report if Necessary
                        If Range("E" & iVPRw) = "ERROR" Then
                            'Copy Data
                                iwsDT1.Activate
                                Range("A" & iVPRw & ":C" & iVPRw).Copy
                            'Insert Data
                                'Activate Sheet
                                    iwsDISP2.Activate
                                'Set To Data Row
                                    iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                                'Insert Data
                                    Range("A" & iTDR).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    Range("D" & iTDR) = "Plant Number Error"
                            'Insert Removal Flag
                                'Activate Sheet
                                    iwsDT1.Activate
                                'Insert Deletion Flag
                                    Range("D" & iVPRw) = "2-DELETE"
                        End If
                Next iVP
        'Remove Identifiers
            'Activate Sheet
                iwsDT1.Activate
            'Remove
                Columns("E:E").Delete
    'Check for Items to Exclude
        'Activate Sheet
            iwsDT1.Activate
        'Insert Formula
            Range("E2") = "=IF(IFERROR(MATCH($A2,'" & iwsCS.Name & "'!$AD:$AD,0),0)>0,""EXCL"","""")"
            Range("E2").AutoFill Destination:=Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
            Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        'Loop and Check Each item
            For Each iVP In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
                'Activate Sheet
                    iwsDT1.Activate
                'Select and Get Row
                    iVP.Select
                    iVPRw = iVP.Row
                'Move to Error Report if Necessary
                    If Range("E" & iVPRw) = "EXCL" Then
                        'Copy Data
                            iwsDT1.Activate
                            Range("A" & iVPRw & ":C" & iVPRw).Copy
                        'Insert Data
                            'Activate Sheet
                                iwsDISP2.Activate
                            'Set To Data Row
                                iTDR = Range("A" & Rows.Count).End(xlUp).Row + 1
                            'Insert Data
                                Range("A" & iTDR).PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                                'Range("D" & iTDR) = "Unable to process BIB Items"
                                Range("D" & iTDR) = Application.XLookup(Range("$A" & iTDR), iwsCS.Range("$AD:$AD"), iwsCS.Range("$AE:$AE"), 0, 0)
                        'Insert Removal Flag
                            'Activate Sheet
                                iwsDT1.Activate
                            'Insert Deletion Flag
                                Range("D" & iVPRw) = "2-DELETE"
                    End If
            Next iVP
            
    'Format Error Report
        'Activate Sheet
            iwsDISP2.Activate
        'Set Widths
            Columns("A:C").ColumnWidth = 12
            Columns("D:D").ColumnWidth = 35
        'Set Borders
            With Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row).Borders
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
    'Remove Items From Main Data Set
        'Activate Sheet
            iwsDT1.Activate
        'Loop and Delete
            'Set Initial Deletion Count
                iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
            'Loop and Delete Items
                Do Until iDelCt = 0
                    'Get Row
                        iDelRw = Application.Match("2-DELETE", iwsDT1.Range("D:D"), 0)
                    'Select and Delete
                        Range("D" & iDelRw).Select
                        Range("D" & iDelRw).EntireRow.Delete
                    'Reset Initial Deletion Count
                        iDelCt = Application.CountIfs(iwsDT1.Range("D:D"), "2-DELETE")
                Loop

'Loop Through Each SKU and set tracker
    'Activate Sheet
        iwsDT1.Activate
    'Loop
        For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            'Activate Sheet
                iwsDT1.Activate
            'Select and get Data
                iSKU.Select
                iSRw = iSKU.Row
            'Save data Sheet Variables
                'Activate Sheet
                    iwsDT1.Activate
                'Set Variables
                    iSKUN = Range("A" & iSRw)                           'SKU
                    iStat = Range("B" & iSRw)                           'Status
                    iPlnt = Range("C" & iSRw)                           'Plant
            'Set Tracker
                'Activate Sheet
                    iwsDISP1.Activate
                'Check if New Item - Add to List if Necessary if already entered find row
                    If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
                        'Set Working Row
                            iWRw = Range("A" & Rows.Count).End(xlUp).Row + 1
                        'Enter Info
                            Range("A" & iWRw) = iSKUN
                            Range("B" & iWRw) = Application.XLookup(Application.Text(iSKUN, 0), iwsCFT1.Range("A:A"), iwsCFT1.Range("B:B"), "N/A", 0)
                        'Generate Status List
                            With Range("D" & iWRw).Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                xlBetween, Formula1:="='" & iwsCS.Name & "'!$AA$3:$AA$5"
                                .IgnoreBlank = True
                                .InCellDropdown = True
                                .InputTitle = ""
                                .ErrorTitle = ""
                                .InputMessage = ""
                                .ErrorMessage = ""
                                .ShowInput = True
                                .ShowError = True
                            End With
                    Else
                        'Set Working Row
                            iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
                    End If
            'Set Column/Range Variable
                'Working Column
                    iWCol = Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0)
                    iWCol = Left(Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1), _
                        Application.Search("$", Right(Cells(1, iWCol).Address, _
                        Len(Cells(1, iWCol).Address) - 1)) - 1)
                'Working Range
                    Dim iWRng As Range
                    Set iWRng = Range(iWCol & iWRw)
                    iWRng.Select
            'Set Block/Unblock
                Select Case iStat
                    Case "Block"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Week
                            iWRng = "Block"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                    Case "Unblock"
                        'Activate Sheet
                            iwsDISP1.Activate
                        'Set Open
                            iWRng = "Unblock"
                        'Set Formatting
                            'Highlight
                                With iWRng.Interior
                                    .Pattern = xlNone
                                    .TintAndShade = 0
                                    .PatternTintAndShade = 0
                                End With
                            'Font
                                With iWRng.Font
                                    .Color = -16776961
                                    .TintAndShade = 0
                                End With
                End Select
        Next iSKU

'Clean Sheet
    'Get End of DataSet
        'Activate Sheet
            iwsDISP1.Activate
        'Final Pull and Variable Set
            iECol = Rows("6:6").End(xlToRight).Column
            iECol = Left(Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1), _
                Application.Search("$", Right(Cells(1, iECol).Address, Len(Cells(1, iECol).Address) - 1)) - 1)
    'Double Check Descriptions
        'Activate Sheet
            iwsDISP1.Activate
        'Loop and Validate Data
            For Each iDCD In Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row)
                'Select and Get Row
                    iDCD.Select
                    iDCDRw = iDCD.Row
                'Check if New Description Required
                    If Range("B" & iDCDRw) = "N/A" Then
                        Range("B" & iDCDRw) = Application.XLookup(Application.Text(Range("A" & iDCDRw), 0), _
                            iwsCFT1.Range("A:A"), _
                            iwsCFT1.Range("B:B"), _
                            "N/A", 0)
                    End If
            Next iDCD
    'Fill Blanks
        'Activate Sheet
            iwsDISP1.Activate
        'Fill data if Necessary
            If Application.CountBlank(iwsDISP1.Range("$E$7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row)) > 0 Then
                'Select Blanks
                    On Error Resume Next
                    Range("$E7:$" & iECol & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Select
                'Set Formatting
                    'Set Text
                        Selection = "Open"
                    'Highlighting
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 5296274
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    'Font
                        With Selection.Font
                            .ThemeColor = xlThemeColorLight1
                            .TintAndShade = 0
                        End With
            End If

'Final Formatting Cleanup
    'Activate Sheet
        iwsDISP1.Activate
    'Set Borders
        With Range("A7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    'Font Size and Format
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).Font.Size = 10
        Range("E7:" & iECol & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
        Range("B7:B" & Range("A" & Rows.Count).End(xlUp).Row).HorizontalAlignment = xlLeft
    'Set Grey Details Highlighting
        With Range("A7:D" & Range("A" & Rows.Count).End(xlUp).Row).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.149998474074526
            .PatternTintAndShade = 0
        End With

End Sub
Private Sub S3_Finalize_Report()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Variables
    'Fiscal Week
        iFWk = iwsCS.Range("D2")
    'Save Path
        iSPth = iwsCS.Range("D4")
    'Email Confirmation - Processing
        iEMConf = iwsCS.Range("D6")
    'Email Confirmation - General Distr
        iEMConf1 = iwsCS.Range("D8")
    'Day
        iDy = Day(Date)
    'Month
        iMth = Month(Date)
        iMthNm = Choose(iMth, "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    'Year
        iYr = Year(Date)
    'Date String
        iDStr = iDy & "-" & iMthNm & "-" & Right(iYr, 2)
    'New Workbook Names
        iwbNew1 = "Central - SKU Blocking Tracker - " & iDStr & ".xlsm"
        iwbNew2 = "Central - SKU Blocking Data - " & iDStr & ".xlsm"
    'Item error Count - Save Table If Necessary
        'Activate Sheet
            iwsDISP2.Activate
        'Set Count
            iErrCt = Range("A" & Rows.Count).End(xlUp).Row - 1
        'Set Range
            Set iDtaRng = iwsDISP2.Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row + 1)
    
'Generate Date on Tracker Sheet
    'Activate Sheet
        iwsDISP1.Activate
        Range("C1") = "Current Week " & iFWk

Dim iwbFmt As Workbook
Dim iwsVis As Worksheet
'Generate Copies
    'Tracker
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew1
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew1
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDISP1.Name).Activate
                'Set View
                    Range("A1").Select
                    Range("E7").Select
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDISP1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True
    'Submission Data
        'Save Copy As
            iwb.SaveCopyAs iSPth & iwbNew2
        'Open and Format
            'Open Book
                Workbooks.Open iSPth & iwbNew2
                Set iwbFmt = ActiveWorkbook
            'Set View
                'Activate Workbook
                    iwbFmt.Sheets(iwsDT1.Name).Activate
                'Set View
                    Range("A1").Select
            'Hide/Unhide Sheets
                'Activate Workbook
                    iwbFmt.Activate
                'Loop and Hide
                    For Each iwsVis In Worksheets
                        'Case select set hide/Unhide
                            Select Case iwsVis.Name
                                Case iwsDT1.Name
                                    On Error Resume Next
                                    iwsVis.Visible = True
                                Case Else
                                    On Error Resume Next
                                    iwsVis.Visible = False
                            End Select
                    Next iwsVis
        'Save and Close workbook
            iwbFmt.Save
            iwbFmt.Close savechanges:=True

'Distribute to Processing if Option Selected
    If iEMConf = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("K" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMTo = iEMTo & Range("K" & iEMRw) & "; "
                Next iEM
            Else
                iEMTo = ""
            End If
        'Generate CC Email
            If Range("L" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEM In Range("L3:L" & Range("L" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEM.Select
                        iEMRw = iEM.Row
                    'Generate String
                        iEMCC = iEMCC & Range("L" & iEMRw) & "; "
                Next iEM
            Else
                iEMCC = ""
            End If
        'Generate Subject Line
            iSubj = "Central - Master Data Delist Tracker - " & iDStr
        'Generate Body
            iMsg = "Hello Everyone," & vbCrLf & vbCrLf & _
                "Attached is the delist tracker for " & iDStr & "." & vbCrLf & vbCrLf & _
                "Thanks," & vbCrLf
        'Generate Email
        Dim olApp As Object
        Dim olMail As Object
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMTo
                    .CC = iEMCC
                    .Subject = iSubj
                    .body = iMsg
                    .Attachments.Add iSPth & iwbNew2
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If

'Distribute to General Option Selected
    If iEMConf1 = "Yes" Then
        'Activate Sheet
            iwsCS.Activate
        'Generate To Email
            If Range("I" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGTo = iEMGTo & Range("I" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGTo = ""
            End If
        'Generate CC Email
            If Range("J" & Rows.Count).End(xlUp).Row > 2 Then
                For Each iEMG In Range("J3:J" & Range("J" & Rows.Count).End(xlUp).Row)
                    'Select and Get Row
                        iEMG.Select
                        iEMRw = iEMG.Row
                    'Generate String
                        iEMGCC = iEMGCC & Range("J" & iEMRw) & "; "
                Next iEMG
            Else
                iEMGCC = ""
            End If
        'Generate Subject Line
            iSubjG = "Central - Delist Tracker - " & iDStr
        'Generate Body - Depends on If Error items Found
            If iErrCt = 0 Then
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Thanks," & "<br>"
            Else
                iMsgG = "Hello Everyone," & "<br>" & "<br>" & _
                    "Attached is the delist tracker for " & iDStr & "." & "<br>" & "<br>" & _
                    "Items were not loaded due to errors detected" & "<br>" & _
                    "Please review and resubmit the following items:" & "<br>" & "<br>" & _
                    RangetoHTML(iDtaRng) & "<br>" & "<br>" & "Thanks," & "<br>"
            End If
        'Generate Email
            'Set Objects
                Set olApp = CreateObject("Outlook.Application")
                Set olMail = olApp.CreateItem(olMailItem)
            'Generate Email
                With olMail
                    .To = iEMGTo
                    .CC = iEMGCC
                    .Subject = iSubjG
                    .HTMLbody = iMsgG
                    .Attachments.Add iSPth & iwbNew1
                    .Display
                End With
            'Clear Objects
                Set olMail = Nothing
                Set olApp = Nothing
    End If
        
End Sub
Private Sub Reconcile()
Application.DisplayAlerts = False
Dim iDtaRng As Range

'=================================================================================================================================
'Created By Halley Szeto, PI Analyst, Customer Excellence - 13 May 21

'Finalizes Report and Generates Distro Email
'=================================================================================================================================

'Save Week
iFWk = iwsCS.Range("D2")

'Execute Reset Call
Call M1_Reset_Sheet

Dim iwbSAP As Workbook
Dim iwsSAP As Worksheet
'Select File to Load
'Set Pathway to Open to
'ChDir ActiveWorkbook.Path
'Run Dialog with Cancellation Error Handling
cancel = Application.GetOpenFilename _
(Title:="Select Central OU Reconcile File to Load")
If cancel = False Then
MsgBox ("Import Session Ended")
Exit Sub
End If
With Workbooks.Open(cancel)
End With
'Set variable Name
Set iwbSAP = ActiveWorkbook
Set iwsSAP = iwbSAP.ActiveSheet

Application.ScreenUpdating = False

Dim iwsTMP1 As Worksheet
'Generate Temp Sheet
'Activate Sheet
iwb.Activate
'Remove Temp Sheet if already exists
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Sheet
Sheets.Add.Name = "TEMP"
Set iwsTMP1 = iwb.Sheets("TEMP")

'Import Data To Main Sheet
'Copy Data
iwsSAP.Activate
Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsTMP1.Activate
Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Close SAP workbook no save
iwbSAP.Close savechanges:=False

'Execute format and clean
'Clean to just relevant Plants and SKUs
'Activate Sheet
iwsTMP1.Activate
'Text to columns material
Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Formula Insert and Fill
Range("G2") = "=IF(AND(" & _
"COUNTIFS('" & iwsDISP1.Name & "'!$6:$6,$C2)>0," & _
"COUNTIFS('" & iwsDISP1.Name & "'!$A:$A,$D2)>0)," & _
"""1-KEEP"",""2-DELETE"")"
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Sort To Group Items for deletion
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:G" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("G:G"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("G" & iSRw & ":G" & iERw).Select
Range("G" & iSRw & ":G" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("G:G"), 0), 0)
Loop
'Remove Identifier
Columns("G:G").Delete
'Duplicates Scrub
'Activate sheet
iwsTMP1.Activate
'Generate Duplicates Identifier
Range("G1") = "Unique ID"
Range("H1") = "Duplicates Count"
'Insert Formulas
Range("G2") = "=$C2&$D2"
Range("H2") = "=IF(COUNTIFS($G:$G,$G2)>1,""2-DUP"","""")"
Range("G2:H2").AutoFill Destination:=Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:H" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Duplicates Correction if detected
If Application.CountIfs(iwsTMP1.Range("$H:$H"), "2-DUP") > 1 Then
'Execute Scrub
'Sort data for Scrub
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Flag Items for Deletion
'Activate Sheet
iwsTMP1.Activate
'Loop and Execute Ident
For Each iDupCt In Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row)
'Select and Get row
iDupCt.Select
iDCRw = iDupCt.Row
'Save Start and End Rows
iUIDS = Range("G" & iDCRw)
iDRS = Application.Match(iUIDS, iwsTMP1.Range("G:G"), 0)
iDRE = iDRS + (Application.CountIfs(iwsTMP1.Range("$G:$G"), iUIDS) - 1)
'Enter Formula
If Application.Rank(iwsTMP1.Range("$E" & iDCRw), iwsTMP1.Range("$E" & iDRS & ":$E" & iDRE), 0) > 1 Then
Range("H" & iDCRw) = "2-DELETE"
Else
Range("H" & iDCRw) = "1-KEEP"
End If
Next iDupCt
'Sort and Delete all Items flagged for deletion
'Activate Sheet
iwsTMP1.Activate
'Sort Items for Deletion Groups
iwsTMP1.Sort.SortFields.Clear
iwsTMP1.Sort.SortFields.Add2 _
Key:=Range("H2:H" & Range("A" & Rows.Count).End(xlUp).Row), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With iwsTMP1.Sort
.SetRange Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Loop and Delete Items
'Set initial Deletion Count
iDelCt = Application.CountIfs(iwsTMP1.Range("H:H"), "2-DELETE")
'Loop Until Deleted
Do Until iDelCt = 0
'Get Start and End Rows
iSRw = Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0)
iERw = iSRw + (iDelCt - 1)
'Select and Delete Items
Range("H" & iSRw & ":H" & iERw).Select
Range("H" & iSRw & ":H" & iERw).EntireRow.Delete
'ReSet initial Deletion Count
iDelCt = Application.IfError(Application.Match("2-DELETE", iwsTMP1.Range("H:H"), 0), 0)
Loop
End If
'Identify Status
'Reset Columns
Columns("G:H").Delete
Range("G1") = "Status"
'Generate Formula
Range("G2") = "=IF(YEAR($F2)=9999,""Unblock"",""Block"")"
Range("G2") = "=IF($F2 "
Range("G2").AutoFill Destination:=Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Resort Data
Columns("C:C").Cut
Columns("A:A").Insert
Columns("G:G").Cut
Columns("A:A").Insert
Columns("E:E").Cut
Columns("A:A").Insert
'Import data to Submitted SKUs Sheet
iwsTMP1.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
iwsDT1.Activate
Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete Temp Sheet
iwsTMP1.Delete

'Loop Through Each SKU and set tracker
'Replicate Actions
'Loop Through Replicate Actions Database
'Activate Sheet
iwsCS.Activate
'Generate Temp Sheet
'Remove Temp Sheet if Pre Existing
On Error Resume Next
iwb.Sheets("TEMP").Delete
'Generate New Temp Sheet
Dim iwsTMP As Worksheet
Sheets.Add.Name = "TEMP"
Set iwsTMP = iwb.Sheets("TEMP")
'Generate Headers
iwsTMP.Activate
Range("A1") = "SKU"
Range("B1") = "Status"
Range("C1") = "Plant"
'Activate Sheet
iwsCS.Activate
'Execute Loop and Search
For Each iRA In Range("AB3:AB" & Range("AB" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsCS.Activate
'Select and Save Data
iRA.Select
iRAR = iRA.Row
iFP = Range("AB" & iRAR)
iTP = Range("AC" & iRAR)
'Execute Loop in Submitted SKUs
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iCK In Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Save Variables
iCK.Select
iCKR = iCK.Row
iPlt = Range("C" & iCKR)
'Check if Replication Required
If iPlt = iFP Then
'Save Data
iSKU = Range("A" & iCKR)
iStat = Range("B" & iCKR)
'Set Temp Row
iwsTMP.Activate
iTMPR = Application.Range("A" & Rows.Count).End(xlUp).Row + 1
'Insert Data
Range("A" & iTMPR) = iSKU
Range("B" & iTMPR) = iStat
Range("C" & iTMPR) = iTP
End If
Next iCK
Next iRA
'Move Data Back to Data Sheet
'Activate Sheet
iwsTMP.Activate
'Check if Import Required
If Range("A" & Rows.Count).End(xlUp).Row > 1 Then
'Copy Data
iwsTMP.Activate
Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Paste Data
iwsDT1.Activate
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
'Delete Temp Sheet
On Error Resume Next
iwsTMP.Delete
'Update Tracker
'Activate Sheet
iwsDT1.Activate
'Loop
For Each iSKU In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Activate Sheet
iwsDT1.Activate
'Select and get Data
iSKU.Select
iSRw = iSKU.Row
'Save data Sheet Variables
'Activate Sheet
iwsDT1.Activate
'Set Variables
iSKUN = Range("A" & iSRw) 'SKU
iStat = Range("B" & iSRw) 'Status
iPlnt = Range("C" & iSRw) 'Plant
'Set Tracker
'Activate Sheet
iwsDISP1.Activate
'Check if New Item - Skip
If Application.IfError(Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0), 0) = 0 Then
GoTo iSkipProcess
Else
'Set Working Row
iWRw = Application.Match(iSKUN, iwsDISP1.Range("A:A"), 0)
End If
'Set Column/Range Variable
'Working Column
'Get Working Column
iWCol = Application.IfError(Application.Match(iPlnt, iwsDISP1.Rows("6:6"), 0), 0)
'Error Handler
If iWCol = 0 Then
GoTo iSkipProcess
Else
'Convert Column Number to Letter
iWCol = Left(Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1), _
Application.Search("$", Right(Cells(1, iWCol).Address, _
Len(Cells(1, iWCol).Address) - 1)) - 1)
End If
'Working Range
Dim iWRng As Range
Set iWRng = Range(iWCol & iWRw)
iWRng.Select
'Set Block/Unblock
Select Case iStat
Case "Block"
'Activate Sheet
iwsDISP1.Activate
'Set Week
iWRng = "Block"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
Case "Unblock"
'Activate Sheet
iwsDISP1.Activate
'Set Open
iWRng = "Unblock"
'Set Formatting
'Highlight
With iWRng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Font
With iWRng.Font
.Color = -16776961
.TintAndShade = 0
End With
End Select
iSkipProcess:
Next iSKU

'Completion Message
Application.ScreenUpdating = False
MsgBox ("Mass System Reconciliation Complete!")

End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
    'Create Temp File
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                             "align=left x:publishsource=")
    'Close TempWB
        TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
        Kill TempFile
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
End Function
In the Reconcile, after the case block or unblock happens and sets the tracker to its status, set the other columns for the other remaining plant numbers for that respective SKU as blank