'All the VBA code I have written for EXCEL

Public CITY
Public STATE
Public ZIP
Public BOLID As Variant
Public N As Integer

Public Function getAddys(ByVal supplier As String) As Collection

    Dim getAddys_ As New Collection
    Dim cell As Range
    
    For Each cell In Range("CosigneeS")
        If supplier = cell Then
            getAddys_.Add Worksheets("REF").Cells(cell.Row, 4)
        End If
    Next cell
    
    Set getAddys = getAddys_
    Set getAddys_ = Nothing
End Function

Function CSZ(theAddy As String) As String

    Dim Lute, Pickle As Range
    
    Set Lute = Worksheets("REF").Range("AddysOnly")
    Debug.Print theAddy

    With Lute
        Set Pickle = Sheets("REF").Columns("D").Find(theAddy, LookIn:=xlValues)

        CITY = Worksheets("REF").Cells(Pickle.Row, 5).Value
        STATE = Worksheets("REF").Cells(Pickle.Row, 6).Value
        ZIP = Worksheets("REF").Cells(Pickle.Row, 7).Value
    End With
    
    CSZ = CITY & "  " & STATE & ", " & ZIP
    Debug.Print CSZ

End Function

Public Function CSZTest()
                
        Set CITY = Nothing
        Set STATE = Nothing
        Set ZIP = Nothing

End Function

Sub EraseBOL()
    With Worksheets("BOL")
        .Range("B2") = ""
        .Range("B4") = ""
        .Range("E4") = ""
        .Range("H4") = ""
        .Range("B6:B8") = ""
        .Range("E7") = ""
        .Range("C14") = ""
        .Range("A14:C24") = ""
        .Range("H14:I24") = ""
    End With
End Sub

Sub PopulateBOL()
Dim rowcount, i, M As Integer
'Dim BOLcrap As Worksheet
'Dim Worksheets("Log1.2") As Worksheet

    'BOLcrap = ActiveWorkbook.Worksheets("BOL")
    'Worksheets("Log1.2") = ActiveWorkbook.Worksheets("Log1.2")
    M = 0
    EraseBOL

    Worksheets("Log1.2").Activate
    rowcount = Range("A2").CurrentRegion.rows.count
    For i = 2 To rowcount
      With ActiveWorkbook.Worksheets("BOL")
        If Range("A" & i).Text = POLFID.TextBox1 Then
            If M < 1 Then
            .Range("B2") = Worksheets("Log1.2").Range("D" & i)
            .Range("B4") = Worksheets("Log1.2").Range("B" & i)
            .Range("E4") = Worksheets("Log1.2").Range("C" & i)
            .Range("H4") = Worksheets("Log1.2").Range("E" & i)
            .Range("B6") = Worksheets("Log1.2").Range("F" & i)
            .Range("B7") = Worksheets("Log1.2").Range("G" & i)
            .Range("B8") = Worksheets("Log1.2").Range("H" & i) & "  " & Worksheets("Log1.2").Range("I" & i) & ",  " & Worksheets("Log1.2").Range("J" & i)
            End If
            If M < 11 Then
            .Range("C" & M + 14) = Worksheets("Log1.2").Range("M" & i)
            .Range("A" & M + 14) = Worksheets("Log1.2").Range("K" & i)
            .Range("H" & M + 14) = Worksheets("Log1.2").Range("L" & i)
            .Range("I" & M + 14) = "=A" & M + 14 & "*H" & M + 14
            Else
                MsgBox "You are out of rows. Plesase add More manually"
            End If
            M = M + 1
        End If
      End With
    Next i
Worksheets("BOL").Activate
End Sub

Function RandomID(leng As Integer) As String
    Dim RID As String
    Dim i, iTemp, Rcout As Integer
    Dim bOK As Boolean
    
    For i = 1 To leng
        Do
            Randomize
            iTemp = Int((122 - 48 + 1) * Rnd + 48)
            Select Case iTemp
            Case 48 To 57, 65 To 90: bOK = True
            Case Else: bOK = False
            End Select
        Loop Until bOK = True
        bOK = False
        RID = RID & Chr(iTemp)
    Next i
    With Worksheets("LOG1.2")
        Rcout = Range("Table2").CurrentRegion.rows.count
        Debug.Print Rcout
        For i = 2 To Rcout
            If .Range("A" & i).Value = RID Then GoTo GetNewRID
        Next i
    End With
    
    RandomID = RID
Exit Function
GetNewRID:
    Debug.Print "New ID!"
    RandomID = RandomID(leng)
End Function

Sub ColLockCell()

    Dim cll As Object
    For Each cll In Selection
        If cll.Locked = True Then
        'cll.Interior.ColorIndex = 9
    Else
        cll.Interior.ColorIndex = 9
    End If
    Next cll
    
    If Selection.Locked = False Then
    MsgBox "There is no locked cell in range that you choose", vbOKOnly, "Locked Cell Checker"
    End If

End Sub

Sub NewCodeForSome()
    Dim i, j As Integer
    Dim CurSelText, NewID As String
    Dim PrevIDs As Collection
    Set PrevIDs = New Collection
    
    LastText = Range("F2").Text
    For i = 2 To 30
        If Range("F" & i).Value <> LastText Then
            PrevIDs.Add (Range("A" & i).Value)
            For j = 1 To PrevIDs.count
                Debug.Print j & "." & PrevIDs(j)
                If Range("A" & i).Value = PrevIDs(j) Then
                    NewID = RandomID(3)
                End If
                Range("A" & i).Value = NewID
            Next j
        End If
    LastText = Range("F" & i).Text
    Next i
End Sub

Sub AllNewIDs()
    Dim i As Integer
    Dim LastText, NewID As String
    
    For i = 2 To 1254
        If Range("F" & i).Value <> LastText Then
            NewID = RandomID(3)
        End If
        Range("A" & i).Value = NewID
    LastText = Range("F" & i).Text
    Next i
End Sub

Sub Copy4th()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+e
'
Dim ColNum As Integer
ColNum = 5

    ActiveCell.Offset(0, ColNum).Range("A1").Select
    Selection.Copy
    
End Sub

Sub MovetoNextRow()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+j
'
Dim ColNum As Integer
ColNum = 5

    ActiveCell.Offset(1, -ColNum).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
End Sub

Sub FormatAsCode39()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+g
'
    cellContent = UCase(Selection.Text)
    If Left(cellContent, 1) <> "*" Then
        Selection.Value = "*" & cellContent & "*"
        Selection.HorizontalAlignment = xlCenter
    End If
    
    With Selection.Font
    .Name = "Code39QuarterInch-Regular"
    .Size = 24
    .Bold = False
    End With

End Sub

Sub FormatMe()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+h
'
    ShowAllRecords
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection.Font
    .Bold = True
    End With
    
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = PickNewColor
    End With
    
    Range(Selection, Selection.SpecialCells(xlLastCell)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous

    With Selection.Font
    .Name = "Calibri"
    End With

    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With
        With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns.AutoFit
    ActiveCell.Select
    FormatToPrint
End Sub
'Don't Ask to Save
Sub Auto_Close()
    ThisWorkbook.Saved = True
End Sub

'Picks new color
Function PickNewColor() As Double
Const BGColor As Long = 13160660  'background color of dialogue
Const ColorIndexLast As Long = 32 'index of last custom color in palette

Dim myNewColor As Double          'color that was picked in the dialogue
Dim myRGB_R As Integer            'RGB values of the color that will be
Dim myRGB_G As Integer            'displayed in the dialogue as
Dim myRGB_B As Integer            '"Current" color
  
  If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast, _
     myRGB_R, myRGB_G, myRGB_B) = True Then
    '"OK" was pressed, so Excel automatically changed the palette
    'read the new color from the palette
    PickNewColor = ActiveWorkbook.Colors(ColorIndexLast)
    'reset palette color to its original value
    ActiveWorkbook.Colors(ColorIndexLast) = myOrgColor
  Else
    '"Cancel" was pressed, palette wasn't changed
    'return old color (or xlNone if no color was passed to the function)
    PickNewColor = 498465
  End If
End Function

'Converts a color to RGB values
Sub Color2RGB(ByVal i_Color As Long, _
              o_R As Integer, o_G As Integer, o_B As Integer)
  o_R = i_Color Mod 256
  i_Color = i_Color \ 256
  o_G = i_Color Mod 256
  i_Color = i_Color \ 256
  o_B = i_Color Mod 256
End Sub

Sub ShowAllRecords()
  If ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
  End If
End Sub

Sub FormatToPrint()
    
    Dim HeaderText As String
    
    HeaderForm.Show
    
    HeaderText = HeaderForm.TextBox1
    
    ActiveWindow.View = xlPageLayoutView
      
    Application.PrintCommunication = False

    With ActiveSheet.PageSetup
    
        .PrintTitleRows = "$1:$1"
        .CenterHeader = HeaderText
        .CenterFooter = "Page &P of &N"

    End With
    Application.PrintCommunication = True
    ActiveWindow.View = xlNormalView
    Cells.Select
    Selection.RowHeight = 20
    Range("A1").Select
End Sub

Sub DeleteHeader()
'
' DeleteHeader Macro
'
' Keyboard Shortcut: Ctrl+k
'
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Save
End Sub

Function ScanCopyBarcode()

On Error GoTo ScanFail
    Dim ScanText, ScanConverted As String
    Dim sFound As Range
    Dim clipboard As DataObject
    Set clipboard = New DataObject
      
    ScanText = InputBox("Scan Away!", "Scan")
    If ScanText = "" Then
        Exit Function
    Else
        Debug.Print ScanText
        ScanConverted = Right(ScanText, Len(ScanText) - 1)
        clipboard.SetText ScanConverted
        clipboard.PutInClipboard
        Debug.Print GetWorkbook(2)
        If GetWorkbook(2) Then
            With Workbooks(2).ActiveSheet
                .Activate
                Set sFound = Cells.Find(What:=ScanConverted, After:=Cells(1, 1), MatchCase:=False)
                If sFound Is Nothing Then
                    MsgBox "Search came up with no results on this sheet."
                Else
                    sFound.Activate
                    ''''''''''Insert Action after Scan Here''''''''''''''
                    'Range("X" & sFound.Row) = ""
                End If
            End With
        Else
            MsgBox "No Other workbook is open, so search was not required."
        End If
    End If
Exit Function
ScanFail:
    MsgBox "The Scan failed."
End Function

Sub LineMemoCrop(LMBook As String)
On Error GoTo LineMemCropError

Dim Planner, Buyer, AdoptPN, Rev, Description, DeletePN, DelDesc, Planner2, FilePath, tempHeader As String
Dim QtyPer, QtyPer2 As Double
Dim EffDate As Date
Dim LineMemo, LMCrop As Worksheet
Dim Counter, Counter2 As Integer
Counter = 1
Counter2 = 3
    FilePath = Range("A7").Text
Set LineMemo = Workbooks(LMBook).Worksheets("Sheet1")
If LineMemo Is Nothing Then
GoTo LineMemCropError
Else
End If
LMCRESUME:
Set LMCrop = Workbooks(LMBook).Worksheets("Sheet2")
'With LineMemo
'    .Activate
'    Range("A" & Counter & ":U" & Counter + 1).Select
'    Selection.Copy
'End With
With LineMemo
    .Activate
    Do While Range("A" & Counter).Value <> "Planner"
        Counter = Counter + 1
    Loop
    Range("A" & Counter - 1 & ":U" & Counter).Select
    Selection.Copy
    Counter = Counter + 1
    Do While Range("A" & Counter).Value <> "" Or Range("L" & Counter).Value <> "" Or Range("K" & Counter) <> ""
    Planner = .Range("A" & Counter).Text
    Planner2 = .Range("R" & Counter).Text
    If Planner <> "ANIXTER" And Planner <> "PHANTOM" And Planner <> "GROUP" And Planner <> "TRANS" And Planner2 <> "ANIXTER" And Planner2 <> "PHANTOM" And Planner2 <> "GROUP" And Planner2 <> "TRANS" Then
        Buyer = .Range("B" & Counter).Text
        QtyPer = .Range("C" & Counter).Value
        AdoptPN = .Range("D" & Counter).Text
        Rev = .Range("E" & Counter).Text
        Description = .Range("F" & Counter).Text
        If IsDate(.Range("K" & Counter)) Then
            EffDate = .Range("K" & Counter)
        Else
            EffDate = 1740904
        End If
        'MsgBox EffDate
        DeletePN = .Range("L" & Counter).Text
        DelDesc = .Range("M" & Counter).Text
        QtyPer2 = .Range("N" & Counter).Value
        If Not IsNull(EffDate) Then
            With LMCrop
                .Range("A" & Counter2) = Planner
                .Range("B" & Counter2) = Buyer
                .Range("C" & Counter2) = QtyPer
                .Range("D" & Counter2) = AdoptPN
                .Range("E" & Counter2) = Rev
                .Range("F" & Counter2) = Description
                .Range("K" & Counter2) = EffDate
                .Range("L" & Counter2) = DeletePN
                .Range("M" & Counter2) = DelDesc
                .Range("N" & Counter2) = QtyPer2
                .Range("R" & Counter2) = Planner2
                Counter2 = Counter2 + 1
            End With
        End If
    End If
    Counter = Counter + 1
    Loop
    
End With
With LMCrop
    Counter = 1
    .Activate
    Cells(1, 1).Select
    .Paste
    With Selection.Font
        .Bold = True
        .Name = "Arial"
        .Size = 10
        .Underline = False
    End With
    While Counter < 22
        tempHeader = Trim(Cells(1, Counter).Text & " " & Cells(2, Counter).Text)
        Cells(1, Counter) = tempHeader
        Counter = Counter + 1
    Wend
    Application.DisplayAlerts = False
    Rows(2).EntireRow.Delete
    For Each Sheet In Application.Worksheets
    If Sheet.Name <> "Sheet2" Then
        Sheet.Delete
    End If
    Application.DisplayAlerts = True
    Next Sheet
    Workbooks(LMBook).Save
End With

Set LineMemo = Nothing
Set LMCrop = Nothing

Exit Sub
Set LineMemo = Nothing
Set LMCrop = Nothing
LineMemCropError:
MsgBox "What Just Happened? " & Error$

End Sub

Sub memoConvertFiles()
On Error GoTo memoConvertFiles_Err
    
    Dim objFS As Object, objFolder As Object
    Dim objFiles As Object, objF1 As Object
    Dim strFolderPath As String
    Dim wb As Workbook
    Dim FileName As String
    
    strFolderPath = Range("A7").Value
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFS.GetFolder(strFolderPath)
    Set objFiles = objFolder.Files
    
    For Each objF1 In objFiles
        FileName = FileNameNoExt(objF1)
        MsgBox "File Name:" & FileName
        Set wb = Workbooks.Open(objF1)
        LineMemoCrop (FileName)
    Next
    
    Set objF1 = Nothing
    Set objFiles = Nothing
    Set objFolder = Nothing
    Set objFS = Nothing
    
    Exit Sub
    
memoConvertFiles_Err:
    MsgBox Err.Number & " " & Err.Description & " " & objF1.Name & " is the wrench. Please remove the wrench."
    
End Sub

Function FileNameNoExt(ByVal strPath As String) As String
 Dim strTemp As String
 strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
 FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
 
'The following function returns the filename with the extension from the file's full path:
Function FileNameWithExt(strPath As String) As String
 FileNameWithExt = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function
 
'the following function will get the path only (i.e. the folder) from the file's ful path:
Function FilePath(strPath As String) As String
 FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function

Public Function GetWorkbook(ByVal wbValue As Integer) As Boolean

    Dim wbReturn As Workbook

    On Error Resume Next
        Set wbReturn = Workbooks(wbValue)

        If wbReturn Is Nothing Then
            GetWorkbook = False
        Else
            GetWorkbook = True
        End If
    On Error GoTo 0

End Function

Function NumberSpotOnShelf()

    Dim wb As Workbook
    Dim sh As Worksheet
    Dim StartCell As Range
    Dim PrevCell, CurCell As String
    Dim rcount, i, SSpot As Integer
    
    Set wb = Workbooks("Shelf Visualizer")
    Set sh = wb.Worksheets(1)
    Set StartCell = Selection
    SSpot = 1
    PrevCell = Cells(StartCell.Row, 1).Value
    rcount = sh.Range("A10000").End(xlUp).Row
    
    For i = 2 To rcount
        CurrCell = Left(Cells(i, StartCell.Column).Value, 6)
        Debug.Print PrevCell & " _ " & CurrCell
        If PrevCell = CurrCell Then
            SSpot = SSpot + 1
        Else
            SSpot = 1
        End If
        Cells(i, StartCell.Column) = CurrCell & ".0" & SSpot
        PrevCell = Left(CurrCell, 6)
    Next i
    Debug.Print
    
End Function

Option Explicit

Public DropUnit As Integer

Sub LogPrintClear()
'
' LogPrintClear Macro
' Copies the data from the worksheet into a sequence log "Log"
' Prints 2 copies of the "Print Area" and then clears the yellow boxes.

' Data validation written by Barry Denning, 3/1/2012
' with modification by Ryan Novachek, 3/4/2012

' Log portion written by Ryan Novachek, 3/4/2012
' Updated 6/3/13 for splitting of MLA/CAB prints in Alstar

' Print and Clear portions written by Barry Denning, 3/1/2012
' Touch up to Log Print and Clear by Jeremy Kronberg 9/4/2014 - 10/17/2014
' Prinable Sequence log with every sequence cart was added 10/7/14
' Easy Button added for Benson because almost every box is blank 10/8/14
' (Module 2) Code for importing single sheets into the program in use added by Jeremy Kronberg 10/9/2014
' Inserting Non-Sequencial Units added by Jeremy Kronberg 12/10/2014
    
' ***Blanks Check***
On Error GoTo TheEnd

Dim CurrentSeq As Integer
Dim AlstarS As String
Dim BoxNumber As String

ActiveSheet.ClearCircles

If Range("B2").Value = 0 Then
    MsgBox ("You must enter the Sequence Number before printing.")
    GoTo TheEnd
ElseIf Range("B3").Value = 0 Then
    MsgBox ("You must enter the Model Number before printing.")
    GoTo TheEnd
ElseIf Range("A5").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "01"
    GoTo TheEnd
ElseIf Range("B5").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "02"
    GoTo TheEnd
ElseIf Range("C5").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "03"
    GoTo TheEnd
ElseIf Range("D5").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "04"
    GoTo TheEnd
ElseIf Range("E5").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "05"
    GoTo TheEnd
ElseIf Range("B7").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "07"
    GoTo TheEnd
ElseIf Range("C7").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "08"
    GoTo TheEnd
ElseIf Range("D7").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "09"
    GoTo TheEnd
ElseIf Range("E7").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "10"
    GoTo TheEnd
ElseIf Range("A9").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "11"
    GoTo TheEnd
ElseIf Range("B9").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "12"
    GoTo TheEnd
ElseIf Range("C9").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "13"
    GoTo TheEnd
ElseIf Range("D9").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "14"
    GoTo TheEnd
ElseIf Range("E9").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "15"
    GoTo TheEnd
ElseIf Range("H5").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "01"
    GoTo TheEnd
ElseIf Range("I5").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "02"
    GoTo TheEnd
ElseIf Range("J5").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "03"
    GoTo TheEnd
ElseIf Range("K5").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "04"
    GoTo TheEnd
ElseIf Range("L5").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "05"
    GoTo TheEnd
ElseIf Range("O5").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "01"
    GoTo TheEnd
ElseIf Range("P5").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "02"
    GoTo TheEnd
ElseIf Range("Q5").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "03"
    GoTo TheEnd
ElseIf Range("R5").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "04"
    GoTo TheEnd
ElseIf Range("S5").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "05"
    GoTo TheEnd
ElseIf Range("H7").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "06"
    GoTo TheEnd
ElseIf Range("I7").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "07"
    GoTo TheEnd
ElseIf Range("J7").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "08"
    GoTo TheEnd
ElseIf Range("K7").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "09"
    GoTo TheEnd
ElseIf Range("L7").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "10"
    GoTo TheEnd
ElseIf Range("O7").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "06"
    GoTo TheEnd
ElseIf Range("H9").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "11"
    GoTo TheEnd
ElseIf Range("J9").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "13"
    GoTo TheEnd
ElseIf Range("K9").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "14"
    GoTo TheEnd
ElseIf Range("L9").Value = 0 Then
    AlstarS = "CAB"
    BoxNumber = "15"
    GoTo TheEnd
ElseIf Range("O9").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "11"
    GoTo TheEnd
ElseIf Range("P9").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "12"
    GoTo TheEnd
ElseIf Range("Q9").Value = 0 Then
    AlstarS = "OIL"
    BoxNumber = "13"
    GoTo TheEnd
ElseIf Range("B11").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "17"
    GoTo TheEnd
ElseIf Range("C11").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "18"
    GoTo TheEnd
ElseIf Range("D11").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "19"
    GoTo TheEnd
ElseIf Range("E11").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "20"
    GoTo TheEnd
ElseIf Range("A13").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "21"
    GoTo TheEnd
ElseIf Range("B13").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "22"
    GoTo TheEnd
ElseIf Range("C13").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "23"
    GoTo TheEnd
ElseIf Range("E13").Value = 0 Then
    AlstarS = "MLA"
    BoxNumber = "25"
    GoTo TheEnd
End If

' ***Log Portion***

CurrentSeq = Range("B2").Value

Application.ScreenUpdating = False

    'Copy Benson Sequence Number Below if it's a Benson or Regular Serial if it is a standard tractor
    Sheets("Alstar Matrix").Select
    Range("B2").Copy
    If (Left(Range("B2").Value, 1) = "6") Then
    Range("K23").PasteSpecial xlPasteValues
    Else
    Range("L23").PasteSpecial xlPasteValues
    End If
    
    Sheets("Log").Select
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Application.CutCopyMode = False
    
    Sheets("Alstar Matrix").Select
    Range("B2").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("A5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("E5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("C9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("D9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("F2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("E9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B11").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("H2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("J5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("L5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("J2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("H7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("I7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("L2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("J7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("M2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("H9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("N2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("K5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("O2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("I5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("P2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("K2").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("Q2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B3").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("J9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("S2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("K7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("T2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("L7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("U2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("C7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("V2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("W2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("C11").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("E13").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("Y2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("D5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("Z2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("D11").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AA2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("E11").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AB2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("A13").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("S13").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AD2").Select
    Selection.PasteSpecial Paste:=xlPasteValues

    Sheets("Alstar Matrix").Select
    Range("O9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AE2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("D7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AF2").Select
    Selection.PasteSpecial Paste:=xlPasteValues

    Sheets("Alstar Matrix").Select
    Range("E7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AG2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("C5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AI2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B13").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AJ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("K9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AK2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("L9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AL2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("C13").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AM2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("O5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AN2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("P5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AO2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("Q5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("R5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AQ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("S5").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AR2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    'Sheets("Alstar Matrix").Select
    'Range("O5").Select
    'Selection.Copy
    
    'Sheets("Log").Select
    'Range("AS2").Select
    'Selection.PasteSpecial Paste:=xlPasteValues
          
    Sheets("Alstar Matrix").Select
    Range("A9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AT2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("O7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AU2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("P9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AV2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("Q9").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AW2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Sheets("Alstar Matrix").Select
    Range("B7").Select
    Selection.Copy
    
    Sheets("Log").Select
    Range("AX2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Range("AY2").Value = Now()

'Fills in Boxes Below for Printing Single Unit Sheets
Sheets("Alstar Matrix").Activate
With Sheets("Alstar Matrix")
.Range("B22") = .Range("B2").Value 'SC093 REF
.Range("C22") = .Range("B2").Value
.Range("B24") = .Range("B2").Value 'SC095 REF
.Range("C24") = .Range("B2").Value
.Range("B28") = .Range("B2").Value 'SC039 REF
.Range("C28") = .Range("B2").Value
.Range("B50") = .Range("B2").Value 'SC124 REF
.Range("C50") = .Range("B2").Value
.Range("B55") = .Range("B2").Value 'SC140 REF
.Range("C55") = .Range("B2").Value
End With

'*********AUTOMATICALLY PRINT SINGLE UNIT SHEETS**********
If Worksheets("Alstar Matrix").Range("A5").Value = "CAB" Then
    Print_SC093
Else
    Print_SC093
    Print_SC039
    Print_SC095
    Print_SC124
    Print_SC140
End If

'*********AUTOMATICALLY PRINT MULTI UNIT SHEETS***************

AutoPrint 9, "SC058", 17, CurrentSeq
AutoPrint 6, "SC100", 25, CurrentSeq
AutoPrint 6, "SC020", 26, CurrentSeq
'AutoPrint 3, "SC109", 39, CurrentSeq
AutoPrint 8, "SC019", 19, CurrentSeq
AutoPrint 8, "SC021", 42, CurrentSeq
AutoPrint 6, "SC026", 44, CurrentSeq
AutoPrint 12, "SC099", 46, CurrentSeq
AutoPrint 12, "SC098", 33, CurrentSeq
'AutoPrint 4, "SC104", 40, CurrentSeq 'DOC Flex Tube
'AutoPrint 10, "SC107", 43, CurrentSeq 'DOC Cans Original
AutoPrint 6, "SC105", 41, CurrentSeq
AutoPrint 8, "SC106", 45, CurrentSeq
AutoPrint 8, "SC040", 21, CurrentSeq
AutoPrint 6, "SC008", 36, CurrentSeq
AutoPrint 8, "SC121", 47, CurrentSeq
AutoPrint 6, "SC122", 48, CurrentSeq
AutoPrint 6, "SC123", 49, CurrentSeq
AutoPrint 6, "SC126", 51, CurrentSeq
'AutoPrint 2, "SC127", 52, CurrentSeq 'Seats Cart
AutoPrint 2, "SC138", 54, CurrentSeq

'CLEAR OUT OLD DATA, GET RID OF ANY CIRCLED BOXES, THEN SAVE

    ClearAllEntries
    Application.ScreenUpdating = True
    ThisWorkbook.Save
    
Exit Sub
TheEnd:
    MsgBox ("You must enter a value for " & AlstarS & " Box " & BoxNumber & " before printing.")
    ActiveSheet.CircleInvalid
    Application.ScreenUpdating = True
End Sub

'**********Prints for any Sequence Sheet*************
'Reqires # of Units per Cart, Cart Name, Entry Row (the row on the Alstar Matrix), and if it includes a Benson Cab
Sub Print_Any(SeqTotal As Integer, SName As String, EntryRow As Integer, Benny As Boolean)
Dim var As Variant
Dim Checks As Boolean
Dim unitNumber As Integer
Dim nextUnit As Integer
Dim MsgRes As VbMsgBoxResult

On Error GoTo CheckFail

Application.ScreenUpdating = True

If Sheets("Alstar Matrix").Range("D" & EntryRow).Value = SeqTotal Then
'Checks If Each Entry Exists in the Log
    For unitNumber = Range("B" & EntryRow).Value To Range("C" & EntryRow).Value
    var = Application.Match(unitNumber, Worksheets("Log").Columns(1), 0)
    Checks = Not (IsError(var))
        If Not Checks Then
        GoTo CheckFail
        Exit Sub
        End If
    Next unitNumber
'Print and Clear Out Alstar and Prep for Next Sequence Entry
    If Checks = True Then
        Sheets(SName).Activate
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
        Sheets("Alstar Matrix").Activate
        nextUnit = Range("C" & EntryRow).Value + 1
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Range("C" & EntryRow).Value
        If Benny Then
            Range("B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow & ",K" & EntryRow).Select
        ElseIf SName <> "SC099" Then
            Range("B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow).Select
            Range("J" & EntryRow).Value = Now()
        Else
            Range("O1,B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow).Select
            Range("J" & EntryRow).Value = Now()
        End If
        Selection.ClearContents
        Range("B" & EntryRow) = nextUnit
    End If
'Special Situation for SC004, SC006, SC007, SC025, SC119, and SC128 which do not increase sequences numerically, but rather checks if the cart is full.
ElseIf SeqTotal = 0 Then
    If Sheets("Alstar Matrix").Range("C" & EntryRow).Value = "Printable" Then
        Sheets(SName).Activate
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
        Sheets("Alstar Matrix").Activate
'Records values on the Matrix page and clears out the portion of the log on the sheet that was printed
        Select Case EntryRow
        Case 20 'Entry Row for SC119
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC119").Range("C16").Value
        Range("J" & EntryRow).Value = Now()
        Sheets(SName).Activate
        Sheets("SC119").Range("B18:C20").Select
        Selection.ClearContents
        
        Case 30 'Entry Row for SC025
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC025").Range("C16").Value
        Range("J" & EntryRow).Value = Now()
        Sheets(SName).Activate
        Sheets("SC025").Range("B17:D22").Select
        Selection.ClearContents
        
        Case 31 'Entry Row for SC004
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC004").Range("C16").Value
        Range("J" & EntryRow).Value = Now()
        Sheets(SName).Activate
        Sheets("SC004").Range("B17:C20").Select
        Selection.ClearContents
        
'        Case 34 'Entry Row for SC006
'        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC006").Range("C16").Value
'        Range("J" & EntryRow).Value = Now()
'        Sheets(SName).Activate
'        Sheets("SC006").Range("B17:C22").Select
'        Selection.ClearContents
        
        Case 35 'Entry Row for SC007
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC007").Range("C16").Value
        Range("J" & EntryRow).Value = Now()
        Sheets(SName).Activate
        Sheets("SC007").Range("B17:D22").Select
        Selection.ClearContents
        
        Case 53 'Entry Row for SC128
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Sheets("SC128").Range("C16").Value
        Range("J" & EntryRow).Value = Now()
        Sheets(SName).Activate
        Sheets("SC128").Range("B17:D19").Select
        Selection.ClearContents
        End Select
        
        Sheets("Alstar Matrix").Activate
        Range("B" & EntryRow).Select
        Selection.ClearContents
    Else
        MsgBox "There are not enough sequence numbers with the correct options to fill the cart."
    End If

ElseIf 0 < Sheets("Alstar Matrix").Range("D" & EntryRow).Value < SeqTotal Then 'And Sheets("Alstar Matrix").Range("D" & EntryRow).Value <> "Enter Seq"
    MsgRes = MsgBox("The sequence numbers don't add up to " & SeqTotal & " units", vbAbortRetryIgnore, "Ignore to Print Partial Seq?")
    If MsgRes = vbIgnore Then
        For unitNumber = Range("B" & EntryRow).Value To Range("C" & EntryRow).Value
        var = Application.Match(unitNumber, Worksheets("Log").Columns(1), 0)
        Checks = Not (IsError(var))
            If Not Checks Then
            GoTo CheckFail
            Exit Sub
            End If
        Next unitNumber
    'Checks If Each Entry Exists in the Log
        If Checks = True Then
            Sheets(SName).Activate
            ActiveWindow.SelectedSheets.PrintOut Copies:=1
            Sheets("Alstar Matrix").Activate
            nextUnit = Range("C" & EntryRow).Value + 1
            Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Range("C" & EntryRow).Value
            If Benny Then
                Range("B" & EntryRow & ":C" & EntryRow & ",K" & EntryRow).Select
            Else
                Range("B" & EntryRow & ":C" & EntryRow).Select
                Range("J" & EntryRow).Value = Now()
            End If
            Selection.ClearContents
            Range("B" & EntryRow) = nextUnit
        End If
    ElseIf MsgRes = vbRetry Then
    Sheets(SName).Activate
    End If
ElseIf DropUnit > 900 Then
    If Not unitNumber = DropUnit Then
    'Checks If Each Entry Exists in the Log
    For unitNumber = Range("B" & EntryRow).Value To Range("C" & EntryRow).Value
    var = Application.Match(unitNumber, Worksheets("Log").Columns(1), 0)
        Checks = Not (IsError(var))
            If Not Checks Then
            GoTo CheckFail
            Exit Sub
            End If
        Next unitNumber
    End If
'Print and Clear Out Alstar and Prep for Next Sequence Entry
    If Checks = True Then
        Sheets(SName).Activate
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
        Sheets("Alstar Matrix").Activate
        nextUnit = Range("C" & EntryRow).Value + 1
        If nextUnit = DropUnit Then nextUnit = nextUnit + 1
        Range("I" & EntryRow).Value = Range("B" & EntryRow).Value & "-" & Range("C" & EntryRow).Value
        If Benny Then
            Range("B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow & ",K" & EntryRow).Select
        ElseIf SName <> "SC099" Then
            Range("B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow).Select
            Range("J" & EntryRow).Value = Now()
        Else
            Range("O1,B" & EntryRow & ":C" & EntryRow & ",H" & EntryRow).Select
            Range("J" & EntryRow).Value = Now()
        End If
        Selection.ClearContents
        Range("B" & EntryRow) = nextUnit
    End If
Else
MsgBox "The sequence cannot be printed with the numbers you have entered."
Exit Sub
End If
Exit Sub
CheckFail:
MsgBox "The Sequence has a number missing.  Check the log to make sure all sequences are entered, otherwise hand out manual build cards."
End Sub

'Checks to see if all units have the correct option codes for custom sequence carts and plugs in the correct units to the sheet.
Sub OC_VARIANT_Check(SC As String)

    'Excel objects.
    Dim m_wbBook As Workbook
    Dim theMatrix As Worksheet
    Dim theLog As Worksheet
    Dim m_ws00h As Worksheet
    Dim rowSC As Integer
    Dim rowLog As Integer
    Dim insertLog As Integer
        
    rowSC = 17
    
    'Initialize the Excel objects.
    Set m_wbBook = ThisWorkbook
    Set theMatrix = m_wbBook.Worksheets("Alstar Matrix")
    Set theLog = m_wbBook.Worksheets("Log")
    Set m_ws00h = m_wbBook.Worksheets(SC)
    
    'Clear out the old data
    m_ws00h.Activate
    Range("B17:D22").Select
    Selection.ClearContents
    
    insertLog = theMatrix.Range("Q2")
    
    If SC = "SC119" Then
            'Find Row in Log - OC Variant with 78T040 or 92T002 options
        If theMatrix.Range("B20").Value <> 0 Then
        
    'If inserting a unit start with that one if it applies to the conditions
            If theMatrix.Range("H20") Then
                If theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And theLog.Range("AB" & insertLog) = "78T040" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC) = "78T040"
                ElseIf theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And theLog.Range("AB" & insertLog) = "92T002" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC) = "92T002"
                End If
                rowSC = rowSC + 1
            End If
     'Otherwise continue with normal sequenced units
          rowLog = theMatrix.Range("G20").Value
            Do
                If theMatrix.Range("B20").Value <= theLog.Range("A" & rowLog) And theLog.Range("AB" & rowLog) = "78T040" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC) = "78T040"
                    rowSC = rowSC + 1
                ElseIf theMatrix.Range("B20").Value <= theLog.Range("A" & rowLog) And theLog.Range("AB" & rowLog) = "92T002" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC) = "92T002"
                    rowSC = rowSC + 1
                End If
                rowLog = rowLog - 1
                
            Loop While rowSC < 20 And rowLog > 1
        End If

'    ElseIf SC = "SC006" Then
'
'    'Find Row in Log - OC Variant with NH.HI or NH.LOW
'        If theMatrix.Range("B34").Value <> 0 Then
'
'    'If inserting a unit start with that one if it applies to the conditions
'            If theMatrix.Range("H34") Then
'                If theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And theLog.Range("W" & insertLog) = "NH.HI" Then
'                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
'                    m_ws00h.Range("C" & rowSC) = "NH.HI"
'                    rowSC = rowSC + 1
'                ElseIf theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And theLog.Range("W" & insertLog) = "NH.LOW" Then
'                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
'                    m_ws00h.Range("C" & rowSC) = "NH.LOW"
'                    rowSC = rowSC + 1
'                End If
'            End If
'     'Otherwise continue with normal sequenced units
'          rowLog = theMatrix.Range("G34").Value
'            Do
'                If theMatrix.Range("B34").Value <= theLog.Range("A" & rowLog) And theLog.Range("W" & rowLog) = "NH.HI" Then
'                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
'                    m_ws00h.Range("C" & rowSC) = "NH.HI"
'                    rowSC = rowSC + 1
'                ElseIf theMatrix.Range("B34").Value <= theLog.Range("A" & rowLog) And theLog.Range("W" & rowLog) = "NH.LOW" Then
'                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
'                    m_ws00h.Range("C" & rowSC) = "NH.LOW"
'                    rowSC = rowSC + 1
'                End If
'                rowLog = rowLog - 1
'
'            Loop While rowSC < 23 And rowLog > 1
'        End If

    ElseIf SC = "SC007" Then
    'Find Row in Log - OC Variant with CIHSTD or CIHPTO
        If theMatrix.Range("B35").Value <> 0 Then
    'If inserting a unit start with that one if it applies to the conditions
            If theMatrix.Range("H35") Then
                If theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And (theLog.Range("W" & insertLog) = "CIHSTD" Or theLog.Range("W" & insertLog) = "CIHPTO" Or theLog.Range("W" & insertLog) = "NH.HI" Or theLog.Range("W" & insertLog) = "NH.LOW") Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$W$" & insertLog
                    m_ws00h.Range("D" & rowSC).Formula = "=Log!" & "$V$" & insertLog
                    rowSC = rowSC + 1
                End If
            End If
    'Otherwise continue with normal sequenced units
         rowLog = theMatrix.Range("G35").Value
            Do
                If theMatrix.Range("B35").Value <= theLog.Range("A" & rowLog) And (theLog.Range("W" & rowLog) = "CIHSTD" Or theLog.Range("W" & rowLog) = "CIHPTO" Or theLog.Range("W" & rowLog) = "NH.HI" Or theLog.Range("W" & rowLog) = "NH.LOW") Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$W$" & rowLog
                    m_ws00h.Range("D" & rowSC).Formula = "=Log!" & "$V$" & rowLog
                    rowSC = rowSC + 1
                End If
                rowLog = rowLog - 1
                
            Loop While rowSC < 23 And rowLog > 1
        End If
            
    ElseIf SC = "SC004" Then
     'Find Row in Log with CIH Radiator
        If theMatrix.Range("B31").Value <> 0 Then
    'If inserting a unit start with that one if it applies to the conditions
            If theMatrix.Range("H31") Then
                If theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And (theLog.Range("V" & insertLog) = "HHPCIH" Or theLog.Range("V" & insertLog) = "LHPCIH") Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$V$" & insertLog
                    rowSC = rowSC + 1
                End If
            End If
        
          rowLog = theMatrix.Range("G31").Value
            Do
                If theMatrix.Range("B31").Value <= theLog.Range("A" & rowLog) And (theLog.Range("V" & rowLog) = "HHPCIH" Or theLog.Range("V" & rowLog) = "LHPCIH") Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$V$" & rowLog
                    rowSC = rowSC + 1
                End If
                rowLog = rowLog - 1
                
            Loop While rowSC < 21 And rowLog > 1
        End If
        
    ElseIf SC = "SC025" Then
    'Find Row in Log - OC Variant with MFD Fender not BLANK
        If theMatrix.Range("B30").Value <> 0 Then
    'If inserting a unit start with that one if it applies to the conditions
            If theMatrix.Range("H30") Then
                If theMatrix.Range("P2").Value = theLog.Range("A" & insertLog) And theLog.Range("AI" & insertLog) <> "BLANK" And theLog.Range("AI" & insertLog) <> "blank" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$AI$" & insertLog
                    rowSC = rowSC + 1
                End If
            End If
            
          rowLog = theMatrix.Range("G30").Value
            Do
                If theMatrix.Range("B30").Value <= theLog.Range("A" & rowLog) And theLog.Range("AI" & rowLog) <> "BLANK" And theLog.Range("AI" & insertLog) <> "blank" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$AI$" & rowLog
                    rowSC = rowSC + 1
                End If
                rowLog = rowLog - 1
                
            Loop While rowSC < 21 And rowLog > 1
        End If
        
    ElseIf SC = "SC128" Then
     'Find Row in Log without CH19
        If theMatrix.Range("B53").Value <> 0 Then
    'If inserting a unit start with that one if it applies to the conditions
            If theMatrix.Range("H53") Then
                If theMatrix.Range("P2").Value <= theLog.Range("A" & insertLog) And theLog.Range("B" & insertLog) <> "CH19" And theLog.Range("AT" & rowLog) <> "BLANK" And theLog.Range("AT" & rowLog) <> "blank" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & insertLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$B$" & insertLog
                    m_ws00h.Range("D" & rowSC).Formula = "=Log!" & "$AT$" & insertLog
                    rowSC = rowSC + 1
                End If
            End If
        
          rowLog = theMatrix.Range("G53").Value
            Do
                If theMatrix.Range("B53").Value <= theLog.Range("A" & rowLog) And theLog.Range("B" & rowLog) <> "CH19" And theLog.Range("AT" & rowLog) <> "BLANK" And theLog.Range("AT" & rowLog) <> "blank" Then
                    m_ws00h.Range("B" & rowSC).Formula = "=Log!" & "$A$" & rowLog
                    m_ws00h.Range("C" & rowSC).Formula = "=Log!" & "$B$" & rowLog
                    m_ws00h.Range("D" & rowSC).Formula = "=Log!" & "$AT$" & rowLog
                    rowSC = rowSC + 1
                End If
                rowLog = rowLog - 1
                
            Loop While rowSC < 19 And rowLog > 1
        End If
    Else
    MsgBox "There was an error!"
    End If
End Sub

'Print_Any: [Units/Sheet (0 if non-sequencial)],[Cart Name],[Alstar Matrix Row],[Benson]

Sub Print_SC024()

Print_Any 2, "SC024", 16, True

End Sub

Sub Print_SC058()

Print_Any 9, "SC058", 17, False

End Sub

Sub Print_SC092()

Print_Any 2, "SC092", 18, True

End Sub

Sub Print_SC019()

Print_Any 8, "SC019", 19, False

End Sub


Sub Print_SC119()

OC_VARIANT_Check ("SC119")
Print_Any 0, "SC119", 20, False

End Sub

Sub Print_SC040()

Print_Any 8, "SC040", 21, False

End Sub

Sub Print_SC093()

Print_Any 1, "SC093", 22, False

End Sub

Sub Print_SC079()
        
Print_Any 12, "SC079", 23, False

End Sub

Sub Print_SC095()

Print_Any 1, "SC095", 24, False

End Sub

Sub Print_SC100()

Print_Any 6, "SC100", 25, False

End Sub

Sub Print_SC020()

Print_Any 6, "SC020", 26, False

End Sub

Sub Print_SC033()

Print_Any 5, "SC033", 27, True

End Sub

Sub Print_SC039()

Print_Any 1, "SC039", 28, False

End Sub

Sub Print_SC018()

Print_Any 6, "SC018", 29, True

End Sub

Sub Print_SC025()

OC_VARIANT_Check ("SC025")
Print_Any 0, "SC025", 30, False

End Sub

Sub Print_SC004()
OC_VARIANT_Check ("SC004")
Print_Any 0, "SC004", 31, False

End Sub

Sub Print_SC054()

Print_Any 4, "SC054", 32, True

End Sub

Sub Print_SC098()

Print_Any 12, "SC098", 33, False

End Sub

Sub Print_SC006()
OC_VARIANT_Check ("SC006")
Print_Any 0, "SC006", 34, False
End Sub

Sub Print_SC007()
OC_VARIANT_Check ("SC007")
Print_Any 0, "SC007", 35, False
End Sub

Sub Print_SC008()

Print_Any 6, "SC008", 36, False

End Sub

Sub Print_SC109()

Print_Any 3, "SC109", 39, False

End Sub

Sub Print_SC104()

Print_Any 4, "SC104", 40, False

End Sub

Sub Print_SC105()

Print_Any 6, "SC105", 41, False

End Sub

Sub Print_SC021()

Print_Any 8, "SC021", 42, False

End Sub

Sub Print_SC107()

Print_Any 10, "SC107", 43, False

End Sub

Sub Print_SC026()

Print_Any 6, "SC026", 44, False

End Sub

Sub Print_SC106()

Print_Any 8, "SC106", 45, False

End Sub

Sub Print_SC099()

Print_Any 12, "SC099", 46, False

End Sub

Sub Print_SC121()

Print_Any 8, "SC121", 47, False

End Sub

Sub Print_SC122()

Print_Any 6, "SC122", 48, False

End Sub

Sub Print_SC123()

Print_Any 6, "SC123", 49, False

End Sub

Sub Print_SC124()

Print_Any 1, "SC124", 50, False

End Sub

Sub Print_SC126()

Print_Any 6, "SC126", 51, False

End Sub

Sub Print_SC127()

Print_Any 2, "SC127", 52, False

End Sub

Sub Print_SC128()

OC_VARIANT_Check ("SC128")
Print_Any 0, "SC128", 53, False

End Sub

Sub Print_SC138()

Print_Any 2, "SC138", 54, False

End Sub

Sub Print_SC140()

Print_Any 1, "SC140", 55, False

End Sub

'Printout of the sheet to record where the sequences left off
Sub Print_Man_Seq()
Sheets("GetSeqPrint").Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Sheets("Alstar Matrix").Activate
End Sub

'Check if the carts are full of sequences so that it can print
Sub RoundedRectangle1_Click()
OC_VARIANT_Check ("SC004")
OC_VARIANT_Check ("SC007")
OC_VARIANT_Check ("SC025")
OC_VARIANT_Check ("SC119")
OC_VARIANT_Check ("SC128")
Sheets("Alstar Matrix").Activate
End Sub

Sub Easy_Benny()
On Error GoTo Bently
    With Sheets("Alstar Matrix")
    If .Range("A2") <> 0 And .Range("K2") <> 0 Then
    .Range("B5:E5,I5:L5,B7:E7,H7:L7,O7,A9:E9,H9,J9:L9,O9:Q9,B11:E11,O5:S5,A13:C13,E13,S13"). _
        Select
    Selection.Value = "BLANK"
    .Range("B3,A5,H5").Select
    Selection.Value = "CAB"
    .Range("B2").Select
    Else
    MsgBox "Please Fill in sequence number and first 4 letters of Benson Serial."
    End If
    End With
Exit Sub
Bently:
MsgBox "Something didn't work with the Benson, Please enter boxes manually."
End Sub

Public Sub AutoPrint(SeqTotal As Integer, CartName As String, EntryRow As Integer, LastEntry As Integer)
On Error GoTo JamInTheRear
Dim ThatCart As String
Dim Insert As Integer

Insert = 0
ThatCart = "Print_" + CartName

With Sheets("Alstar Matrix")
    If .Range("H" & EntryRow).Value = "TRUE" Or .Range("H" & EntryRow).Value = True Then
        Insert = 1
    End If
    If .Range("B" & EntryRow).Value + Insert + SeqTotal - 1 = LastEntry Then
        .Range("C" & EntryRow) = LastEntry
'Is Same as Print_SC***
        Application.Run ThatCart
    End If
End With

Exit Sub
JamInTheRear:
MsgBox "Something is jammed up!  Make sure you have the correct starting sequence in the box for " & CartName & ">"
End Sub

Sub InsertNon()
On Error GoTo NonSequencial
With Sheets("Alstar Matrix")
    .Range("O1,H16:H21,H25:H27,H29:H49,H51:H54").Select
    Selection.Value = True
    .Range("K16,K18,K27,K29,K32").Select
    Selection.Value = .Range("P2").Value
End With

Exit Sub
NonSequencial:
MsgBox "Something didn't work with the Non-Sequencial Unit.  Please contact the Alstar Programmer"
End Sub

Sub RemoveNon()
On Error GoTo NonSequencial
With Sheets("Alstar Matrix")
    .Range("O1,H16:H21,H25:H27,H29:H49,H51:H54").Select
    Selection.Value = False
    .Range("P2").Select
    Selection.Value = ""
End With

Exit Sub
NonSequencial:
MsgBox "Something didn't work with the Non-Sequencial Unit.  Please contact the Alstar Programmer"
End Sub

Sub ClearAllEntries()
On Error GoTo CEError
    Sheets("Alstar Matrix").Select
    ActiveSheet.ClearCircles
    
    Sheets("Alstar Matrix").Select
    Range("B2,B3,K2,A5:E5,H5:L5,O5:S5,B7:E7,H7:L7,O7,A9:E9,H9,J9,K9,L9,O9:Q9,B11:E11,A13:C13,E13,S13"). _
        Select
    Range("E13").Activate
    Selection.ClearContents
    Range("B2").Activate
Exit Sub
CEError:
MsgBox "There was an error clearing out the entries."
End Sub

Sub ScrollToDOC()
' Scrolls over to the DOC entries
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    Range("O5").Select
End Sub

Sub ScrollToMLA()
' Scrolls over to the DOC entries
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("B2").Select
End Sub

Sub PrintDU()
    MsgBox DropUnit
End Sub

Public OSDID As Variant
Public TableUpdated As Boolean
Public TableNamed As String
Public N As Integer
Public SpecialN As String

Sub EraseOSD()
    OSDID = vbNullString
    With Worksheets("INBOUND ISSUE FORM")
        .Range("B2") = "ID:"
        .Range("G3,C4,C6,G7") = ""
        .Range("C8,C10,C12,C14,C16") = ""
        .Range("C18,E18,G18") = ""
        .Range("C28,G28") = ""
        .Range("C20,C22,C24,C26,C30,B32,B34") = ""
        .Range("C36,E36") = 1
        .Shapes("OvalHand").Visible = False
        .Shapes("OvalWeigh").Visible = False
        .Shapes("RoundedVOID").Visible = False
    End With
End Sub

Sub ErasePNOSD()
    OSDID = vbNullString
    With Worksheets("INBOUND ISSUE FORM")
        .Range("C14,C18,E18,G18,C28,G28,C30") = ""
    End With
End Sub

Sub PopulateOSD(IDVal As String)
Dim rowcount, i As Integer
    EraseOSD
    Worksheets("Log").Activate
    rowcount = Range("A2").CurrentRegion.rows.count
    For i = 2 To rowcount
      With ActiveWorkbook.Worksheets("INBOUND ISSUE FORM")
        If Range("A" & i).Text = IDVal Then
            .Range("B2") = "ID: " & Worksheets("Log").Range("A" & i)
            .Range("G3") = Worksheets("Log").Range("B" & i)
            .Range("C4") = Worksheets("Log").Range("C" & i)
            .Range("C6") = Worksheets("Log").Range("D" & i)
            .Range("G7") = Worksheets("Log").Range("E" & i)
            .Range("C8") = Worksheets("Log").Range("F" & i)
            .Range("C10") = Worksheets("Log").Range("G" & i)
            .Range("C12") = Worksheets("Log").Range("H" & i)
            .Range("C14") = Worksheets("Log").Range("I" & i)
            .Range("C16") = Worksheets("Log").Range("J" & i)
            .Range("C18") = Worksheets("Log").Range("K" & i)
            .Range("E18") = Worksheets("Log").Range("L" & i)
            .Range("G18") = Worksheets("Log").Range("M" & i)
            .Range("C20") = Worksheets("Log").Range("N" & i)
            .Range("C22") = Worksheets("Log").Range("O" & i)
            .Range("C24") = Worksheets("Log").Range("P" & i)
            .Range("C28") = Worksheets("Log").Range("Q" & i)
            .Range("G28") = Worksheets("Log").Range("R" & i)
            .Range("C26") = Worksheets("Log").Range("S" & i)
            SpecialN = Worksheets("Log").Range("T" & i)
            SplitTextCustom (SpecialN)
            If Worksheets("Log").Range("U" & i) > 0 Then
                .Range("C36") = 1
                .Range("E36") = Worksheets("Log").Range("U" & i)
            Else
                .Range("C36") = 0
                .Range("E36") = 0
            End If
            N = Worksheets("Log").Range("U" & i)
            .Shapes("RoundedVOID").Visible = Worksheets("Log").Range("V" & i)
            .Shapes("OvalWeigh").Visible = Worksheets("Log").Range("W" & i)
            .Shapes("OvalHand").Visible = Not Worksheets("Log").Range("W" & i)
        End If
      End With
    Next i
OSDID = IDVal
Worksheets("INBOUND ISSUE FORM").Activate
End Sub

Function ArticleGen(IWord As String) As String
    Dim FL As String
    FL = UCase(Left(IWord, 1))
    If FL = "A" Or FL = "E" Or FL = "I" Or FL = "O" Or FL = "U" Then
        ArticleGen = "An"
    Else
        ArticleGen = "A"
    End If
End Function

'Sub rID_tEST()
'    MsgBox RandomIDA(4)
'End Sub

Function RandomIDA(leng As Integer) As String
    Dim rID As String
    Dim i, iTemp, Rcout As Integer
    Dim bOK As Boolean
    
    For i = 1 To leng
        Do
            Randomize '90
            iTemp = Int((90 - 65 + 1) * Rnd + 65)
            Select Case iTemp
            Case 65 To 90: bOK = True
            Case Else: bOK = False
            End Select
        Loop Until bOK = True
        bOK = False
        rID = rID & Chr(iTemp)
    Next i
    With Worksheets("Log")
        Rcout = Range("Table2").CurrentRegion.rows.count
        Debug.Print Rcout
        For i = 2 To Rcout
            If .Range("A" & i).Value = rID Then GoTo GetNewRID
        Next i
    End With
    
    RandomIDA = rID
Exit Function
GetNewRID:
    Debug.Print "New ID!"
    RandomIDA = RandomIDA(leng)
End Function

Sub ColLockCell()

    Dim cll As Object
    For Each cll In Selection
        If cll.Locked = True Then
        'cll.Interior.ColorIndex = 9
    Else
        cll.Interior.ColorIndex = 9
    End If
    Next cll
    
    If Selection.Locked = False Then
    MsgBox "There is no locked cell in range that you choose", vbOKOnly, "Locked Cell Checker"
    End If

End Sub

Function MatchingLetters(Str1 As Variant, Str2 As Variant) As Integer
    Dim i, j, minoftwo As Integer
    Dim CharD As String
    j = 0
    If Len(Str1) > Len(Str2) Then
        minoftwo = Len(Str2)
    Else
        minoftwo = Len(Str1)
    End If
    For i = 1 To minoftwo
        If Mid(Str1, i, 1) = Mid(Str2, i, 1) Then
            j = j + 1
        End If
    Next i
    MatchingLetters = j
End Function

Sub show_circles()
        Worksheets("INBOUND ISSUE FORM").Shapes("OvalHand").Visible = True
        Worksheets("INBOUND ISSUE FORM").Shapes("OvalWeigh").Visible = True
End Sub

Sub SortTable(TableName As String)
    'Takes the Name of any table in the worksheet and sorts that table
    ActiveWorkbook.Worksheets("REF").ListObjects(TableName).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("REF").ListObjects(TableName).Sort.SortFields.Add Key _
        :=Range(TableName), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("REF").ListObjects(TableName).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub PrintIteratedSheets()
    Dim i As Integer
    i = 0
    With Worksheets("INBOUND ISSUE FORM")
        If .Range("C28") = "" Or .Range("G28") = "" Then
            MsgBox "Have the Count verified before printing"
            .Range("C28").Select
        Else
            .Activate
            .Range("E36") = N
            While i < N
                .Range("C36") = i + 1
                .PrintOut
                i = i + 1
            Wend
        End If
    End With
End Sub

Sub OutlookMail_5(WorkSHEETtoEMAIL As String)
'Automate Sending Emails from Excel, using Outlook. Create a New Workbook, Add a New Sheet from the Host _
Workbook, send the new workbook as an attachment with the mail.

'Automating Outlook from Excel, using Late Binding. You need not add a reference to the Outlook object _
library in Excel (your host application), in this case you will not be able to use the Outlook's predefined _
constants and will need to replace them by their numerical values in your code.

'Code written by Amit Tandon - http://www.globaliconnect.com/

'variables declared as Object Type, which can be a reference to any object:
Dim oApplOL As Object
Dim oMiOL As Object
Dim oRecptOL As Object
Dim wbHost As Workbook
Dim wb As Workbook
Dim wsNewSheet As Worksheet
Dim strWbName, strWbPath, DelFile As String
Dim strFileExtn As String
Dim lFileFrmt As Long
Dim SheetCount, j As Integer
Dim VendorName, Discrep, PartNum, ReceivedBy, PlannerName, PlannerEmail, VoidText, strMailSubject, strMailMessage As String
Dim rspCreate As VbMsgBoxResult
Dim Void As Boolean

    'Application.ScreenUpdating Property. If set to False, screen updating will be turned off, and you will not be able to view _
    what your code does but it executes faster. It is common to turn off screen updating in vba procedures to make codes run faster.
    Application.ScreenUpdating = False
    VendorName = Range("C4")
    Discrep = Range("C10")
    PartNum = Range("C14")
    ReceivedBy = Range("C22")
    PlannerName = Range("C24")
    SpecialNote = Application.VLookup(OSDID, Range("Table2"), 20, 0)
    Void = CBool(Application.VLookup(OSDID, Range("Table2"), 22, 0))
    PlannerEmail = CStr(Application.VLookup(Range("C24"), Range("Table5"), 2))
    'Create a new instance of the Outlook application, if an existing Outlook object is not available.
    'Set the Application object as follows:
    On Error Resume Next
    Set oApplOL = GetObject(, "Outlook.Application")
    
    'if an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
    If Err.Number <> 0 Then
        Set oApplOL = CreateObject("Outlook.Application")
    End If

    'disable error handling:
    On Error GoTo 0
    
    Set wbHost = ActiveWorkbook
    
    'Choose the excel File Type & Format for the new workbook:
    'It is advisable to use values in lieu of built-in constants, so that the code runs across all office / excel versions: _
    xlWorkbookNormal = -4143; xlExcel8 = 56; xlOpenXMLWorkbook = 51; xlOpenXMLWorkbookMacroEnabled = 52; xlExcel12 = 50.
    'Built-in constants have been replaced by their values below.

    strFileExtn = ".xlsx"
    lFileFrmt = 51
    
    'set path where to save the New Workbook, to the same location as the host workbook:
    strWbPath = ThisWorkbook.Path
    'set name for the New Workbook with the defined path and the file extension as determined above:
    strWbName = strWbPath & "\" & VendorName & "\" & Year(Date) & "\" & VendorName & " " & Discrep & " " & PartNum & " " & Format(Now(), "mm-dd-yy")
    'add new workbook:
    Set wb = Workbooks.Add
    
    If Void Then
        strWbName = strWbPath & "\" & VendorName & "\" & Year(Date) & "\" & VendorName & " VOID " & PartNum & " " & Format(Now(), "mm-dd-yy")
        'DelFile = strWbPath & "\" & VendorName & "\" & Year(Date) & "\" & GetFullFileName(strWbPath & "\" & VendorName & "\" & Year(Date) & "\", VendorName & " " & Discrep & " " & PartNum)
        ''Debug.Print DelFile
        'If (Dir(DelFile & ".pdf") <> "") Then
        '    SetAttr DelFile & ".pdf", vbNormal
        '    Kill (DelFile & ".pdf")
        'Else
        '    MsgBox "Previous Report Could not be found. (for deleting purposes)"
        'End If
    Else
        strWbName = strWbPath & "\" & VendorName & "\" & Year(Date) & "\" & VendorName & " " & Discrep & " " & PartNum & " " & Format(Now(), "mm-dd-yy")
        If Dir(strWbPath & "\" & VendorName & "\", vbDirectory) = "" Then
        rspCreate = MsgBox("\" & VendorName & "\" & " doesn't exist, do you wish to create it?", vbYesNo)
            If rspCreate = vbYes Then
                MkDir strWbPath & "\" & VendorName & "\"
            Else
                MsgBox "Report Not Filed."
                wb.Close
                Exit Sub
            End If
            If Dir(strWbPath & "\" & VendorName & "\" & Year(Date) & "\", vbDirectory) = "" Then
            rspCreate = MsgBox("\" & VendorName & "\" & Year(Date) & "\" & " doesn't exist, do you wish to create it?", vbYesNo)
                If rspCreate = vbYes Then
                    MkDir strWbPath & "\" & VendorName & "\" & Year(Date) & "\"
                End If
            End If
        End If
    End If
    'save the new workbook with its name, file format and password:
    ''''''''wb.SaveAs Filename:=strWbName & strFileExtn, FileFormat:=lFileFrmt, ReadOnlyRecommended:=False
    'copy sheet from host workbook to new workbook, at the end:
    wbHost.Sheets(WorkSHEETtoEMAIL).Copy After:=wb.Sheets(wb.Sheets.count)
    DeleteBlankSheets (wb.Sheets.count - 1)
    Remove_Buttons (1)
    'save the new workbook:
    ''''''''wb.Save
    
    'Save Sheet as PDF
    wb.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=strWbName & ".pdf", Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    'close new workbook
    wb.Close False
    'create mail item:
    'Built-in constant olMailItem has been replaced by its value 0.
    Set oMiOL = oApplOL.CreateItem(0)
    'add main mail recipient:
    If Left(PlannerEmail, 5) <> "Error" Then
        Set oRecptOL = oMiOL.Recipients.Add(PlannerEmail)
    End If
    'add mail recipients:
    Set oRecptOL = oMiOL.Recipients.Add("aragio@4linc.com")
    Set oRecptOL = oMiOL.Recipients.Add("ryan.novachek@4linc.com")
    Set oRecptOL = oMiOL.Recipients.Add("akivisto@4linc.com")
    Set oRecptOL = oMiOL.Recipients.Add("ENicholson@4linc.com; RMiles@4linc.com; SMitchell@4linc.com; KLiegakos@4linc.com; JBeck@4linc.com; EBodendorfer@4linc.com")
    Set oRecptOL = oMiOL.Recipients.Add("jkronberg@4linc.com")
    
    If Void Then
        VoidText = " has been VOIDED for "
    Else
        VoidText = " has been filed for "
    End If
    'write out email title and body
    strMailSubject = VendorName & " - " & Discrep
    strMailMessage = PlannerName & "," & vbNewLine & vbNewLine & _
    ArticleGen(CStr(Discrep)) & " " & Discrep & _
    VoidText & VendorName & "." & vbNewLine & _
    SpecialNote & vbNewLine & vbNewLine & _
    "Regards," & vbNewLine & ReceivedBy
    'Built-in constant olTo has been replaced by its value 1.
    oRecptOL.Type = 1
    
    With oMiOL
        'Built-in constant olImportanceNormal has been replaced by its value 1.
        .Importance = 1
        .Subject = strMailSubject
        .Body = strMailMessage
        'send new workbook as attachment to the mail:
        '.Attachments.Add wb.FullName
        .Attachments.Add strWbName & ".pdf"
        .ReadReceiptRequested = False
        .Save
        .Display
    End With
    
    Application.ScreenUpdating = True
    
'clear the object variables:
Set oApplOL = Nothing
Set oMiOL = Nothing
Set oRecptOL = Nothing

End Sub

Sub Remove_Buttons(i As Integer)
        ActiveWorkbook.Worksheets(i).Buttons.Delete
End Sub

Sub DeleteBlankSheets(j As Integer)
On Error Resume Next
Dim i As Integer
For i = 1 To j
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Sheet" & i).Delete
    Application.DisplayAlerts = True
Next i
End Sub

Sub VOID_Form()
    Dim c As Range
    Dim Resp As Integer
    If OSDID = "" Then
        MsgBox "The program needs to be sure of the ID of the issue you are voiding. Repopulate the form from the Log sheet to fix."
        Worksheets("Log").Activate
        Exit Sub
    End If
    With Worksheets("Log")
        Set c = .Range("A:A").Find(OSDID, LookIn:=xlValues)
        If .Range("V" & c.Row) Then GoTo UNVOID
        .Range("V" & c.Row) = True
        .Range("B" & c.Row & ":I" & c.Row).Interior.Pattern = xlSolid
        .Range("B" & c.Row & ":I" & c.Row).Interior.PatternColorIndex = xlAutomatic
        .Range("B" & c.Row & ":I" & c.Row).Interior.Color = 192
    End With
    Worksheets("INBOUND ISSUE FORM").Shapes("RoundedVOID").Visible = True
Exit Sub
UNVOID:
    Resp = MsgBox("Form is already void. Would you like to remove the VOID?", vbYesNo)
    If Resp = vbYes Then
        With Worksheets("Log")
            .Range("V" & c.Row) = ""
            .Range("B" & c.Row & ":I" & c.Row).Interior.Pattern = xlNone
        End With
        Worksheets("INBOUND ISSUE FORM").Shapes("RoundedVOID").Visible = False
    End If
End Sub

Sub UNVOID_Form()
    With Worksheets("Log")
        Set c = .Range("A:A").Find(OSDID, LookIn:=xlValues)
        .Range("V" & c.Row) = ""
    End With
    Worksheets("INBOUND ISSUE FORM").Shapes("RoundedVOID").Visible = False
End Sub

Sub Monthtest()
    MsgBox MonthName(Month(Date), True) & " " & Year(Date)
End Sub
 
Sub SplitTextCustom(MyText As String)
    Dim CutText As String, WrapLength As Integer, StrLen As Long, j As Long
     
    Application.EnableEvents = False
    'Number of Characters before splitting string
    WrapLength = 59
    'Analyse text for space preceding cell width and split text
    With ThisWorkbook.Worksheets("INBOUND ISSUE FORM")
        StrLen = Len(MyText)
        If Len(MyText) > WrapLength Then
            For j = WrapLength To 0 Step -1
                If j = 0 Then Exit For
                If Mid(MyText, j, 1) = " " Then
                    .Range("C30").Formula = Left(MyText, j)
                    CutText = Right(MyText, StrLen - j)
                    Exit For
                End If
            Next
        Else
            .Range("C30").Formula = MyText
            Exit Sub
        End If
        WrapLength = 80
        StrLen = Len(CutText)
        If StrLen > WrapLength Then
            For j = WrapLength To 0 Step -1
                If j = 0 Then Exit For
                If Mid(CutText, j, 1) = " " Then
                    .Range("B32").Formula = Left(CutText, j)
                    CutText = Right(CutText, StrLen - j)
                    Exit For
                End If
            Next
        Else
            .Range("B32").Formula = CutText
            GoTo EndofProg
        End If
        StrLen = Len(CutText)
        If StrLen > WrapLength Then
            For j = WrapLength To 0 Step -1
                If j = 0 Then Exit For
                If Mid(CutText, j, 1) = " " Then
                    .Range("B34").Formula = Left(CutText, j)
                    CutText = Right(CutText, StrLen - j)
                    Exit For
                End If
            Next
        Else
            .Range("B34").Formula = CutText
        End If
    End With
EndofProg:
    Application.EnableEvents = True
End Sub

Function GetFullFileName(strfilepath As String, _
strFileNamePartial As String) As String
On Error Resume Next

Dim objFS As Variant
Dim objFolder As Variant
Dim objFile As Variant
Dim intLengthOfPartialName As Integer
Dim strfilenamefull As String

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.getfolder(strfilepath)

'work out how long the partial file name is
intLengthOfPartialName = Len(strFileNamePartial)

For Each objFile In objFolder.Files

'Test to see if the file matches the partial file name
If Left(objFile.Name, intLengthOfPartialName) = strFileNamePartial Then

'get the full file name
strfilenamefull = objFile.Name
Exit For

Else

End If

Next objFile

'Return the full file name as the function's value
GetFullFileName = Left(strfilenamefull, InStrRev(strfilenamefull, ".") - 1)

End Function

Sub TestSCT()
    SplitTextCustom ("This is just for shi** and googles.  You have to have a certain length of text for it to put anything in these blanks.")
End Sub

Sub ConvertCSV()
'
' ConvertCSV Macro
' Convert Inventory Dump to Proper Format
'
' Keyboard Shortcut: Ctrl+i
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String

DirN = Sheet1.Cells(2, 4).Value
FileN = Sheet1.Cells(3, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN, Origin:= _
        xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 3), Array(7, 3)), _
        TrailingMinusNumbers:=True
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat _
        :=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True
        
Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub PNDConvertXLS()
'
' PNDConvertXLS Macro
' Convert Part Number Details Dump to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(10, 4).Value
FileN = Sheet1.Cells(11, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Cells(1, 1).Text
    If SomeText = "Part Number Details" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub


Sub eKMTConvertXLS()
'
' PNDConvertXLS Macro
' Convert eKanban Master Dump to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(16, 4).Value
FileN = Sheet1.Cells(17, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Cells(1, 1).Text
    If SomeText = "eKanbanMaster Table Info" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub MinsV2XLS()
'
' MinsV2XLS Macro
' Convert Min Report to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(23, 4).Value
FileN = Sheet1.Cells(24, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Cells(1, 1).Text
    If SomeText = "WH Supermarket Mins_v2" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub TotesExceedingXLS()
'
' TotesExcedingXLS Macro
' Convert TotesExcede to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(29, 4).Value
FileN = Sheet1.Cells(30, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Left(Cells(1, 1).Text, 20)
    If SomeText = "eKanban Totes Exceed" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub ConvertInvDumpCSV()
    Workbooks.OpenText filename:="C:\Repack DB\InventoryDump.csv", Origin:= _
        xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 3), Array(7, 3)), _
        TrailingMinusNumbers:=True
    ActiveWorkbook.SaveAs filename:="C:\Repack DB\InventoryDump.csv", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.Quit
End Sub

Sub InvDumpXLS()
'
' InvDumpXLS Macro
' Convert Inventory Dump to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(35, 4).Value
FileN = Sheet1.Cells(36, 3).Value

    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Cells(1, 1).Text
    If SomeText = "Inventory Dump" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    Range("A1").Value = "CurrentLocation"
    Range("B1").Value = "PartNumber"
    Range("C1").Value = "PlantCode"
    Range("D1").Value = "SerialNumber"
    Range("E1").Value = "ContainerQty"
    Range("F1").Value = "CreationDate"
    Range("G1").Value = "textbox9"
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub eKanbanToteDetails()
'
' TotesExcedingXLS Macro
' Convert TotesExcede to Proper Format
'
On Error GoTo Hell

Dim DirN As String
Dim FileN As String
Dim SomeText As String

DirN = Sheet1.Cells(41, 4).Value
FileN = Sheet1.Cells(42, 3).Value
'MsgBox "Cell value is " & filen, , "Du mussen deiser cells gefillen aus!"
    Workbooks.OpenText filename:=DirN & "\" & FileN
    Application.DisplayAlerts = False
    SomeText = Left(Cells(1, 1).Text, 20)
    If SomeText = "eKanbanDetails Table" Then
       Rows("1:1").Select
       Selection.Delete Shift:=xlUp
    End If
    ChDir DirN
    ActiveWorkbook.SaveAs filename:=DirN & "\" & FileN, FileFormat:=xlExcel8, ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

Exit Sub

Hell:
MsgBox "Any number of things could trigger this: " & Error$, vbOKOnly
End Sub

Sub CopyFromTo()
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim DirFrum As String
Dim DirTou As String
Dim FileN As String

DirFrum = Sheet1.Cells(20, 12).Value
DirTou = Sheet1.Cells(21, 12).Value
FileN = Sheet1.Cells(22, 11).Value

MsgBox DirFrum & "\" & FileN & vbNewLine & DirTou
Call fso.CopyFile(DirFrum & "\" & FileN, DirTou & "\" & FileN, True)

End Sub

Sub folder_names_including_subfolder()
    Application.ScreenUpdating = False
    Dim fldpath
    Dim fso As Object, j As Long, folder1 As Object
    Dim getYear As String
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
    End With
    On Error Resume Next
    fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
    
    If fldpath = False Then
        MsgBox "Folder Not Selected"
        Exit Sub
    End If
    
    getYear = InputBox("What Year are you looking to import into excel?", "Year")
    
    Workbooks.Add
    Cells(1, 1).Value = fldpath
    Cells(2, 1).Value = "Path"
    Cells(2, 2).Value = "Name"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder1 = fso.getfolder(fldpath)
    
    get_sub_folder folder1, getYear
    'Make2016Folders folder1, getYear
    
    Set fso = Nothing
    Exit Sub
    Range("a1").Font.Size = 9
    ActiveWindow.DisplayGridlines = False
    Range("A3:B" & Range("a2").End(xlDown).Row).Font.Size = 9
    Range("A2:B2").Interior.Color = vbCyan
    Columns("A:B").AutoFit
    Application.ScreenUpdating = True
End Sub

Sub MakeFolderForYear()
    Dim fldpath
    Dim fso As Object, folder1 As Object
    Dim getYear As String
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
    End With
    On Error Resume Next
    fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

    If fldpath = False Then
        MsgBox "Folder Not Selected"
        Exit Sub
    End If
    getYear = InputBox("What Year are you looking to import into excel?", "Year")
        Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder1 = fso.getfolder(fldpath)
    
    Make2016Folders folder1, getYear
    
    Set fso = Nothing
End Sub

Sub get_sub_folder(ByRef prntfld As Object, ByVal YearF As String)
    Dim SubFolder As Object, subfld As Object, File As Object, j As Long
    Dim dotPos As Integer
    For Each SubFolder In prntfld.SubFolders
        If SubFolder.Name = YearF Then
            For Each File In SubFolder.Files
                If File.Name <> "Thumbs.db" Then
                    j = Range("A1").End(xlDown).Row + 1
                    Cells(j, 1).Value = SubFolder.Path
                    dotPos = InStrRev(File.Name, ".")
                    Cells(j, 2).Value = Left(File.Name, dotPos - 1)
                    j = j + 1
                End If
            Next File
        End If
    Next SubFolder

    For Each subfld In prntfld.SubFolders
        get_sub_folder subfld, YearF
    Next subfld
End Sub

Sub Make2016Folders(ByRef dasDirectory As Object, ByVal YearF As String)
    Dim SubFolder As Object

    For Each SubFolder In dasDirectory.SubFolders
        Debug.Print SubFolder & "\" & YearF
    
    If Len(Dir(SubFolder & "\" & YearF, vbDirectory)) = 0 Then
        MkDir SubFolder & "\" & YearF
    End If
    Next SubFolder

End Sub

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+l
'
    ActiveWorkbook.Worksheets("Route Configuraton").AutoFilter.Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Route Configuraton").AutoFilter.Sort.SortFields.Add _
        Key:=Range("B1:B201"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Route Configuraton").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Sub Macro2()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+y

    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\jkronberg\Documents\Visual Studio 2005\Projects\super\super\shelprop.csv" _
        , FileFormat:=xlCSV, CreateBackup:=False
End Sub

Sub CartsShredder()
    Dim PFEP, RC As Workbook
    Dim MC, CALC, SETUP As Worksheet
    Set RC = Workbooks(2) 'Depends on the order opened in Excel
    Set PFEP = Workbooks(1) 'Depends on the order opened in Excel
    Set MC = PFEP.Worksheets("MASTER CARTS")
    Set CALC = RC.Worksheets("Calc")
    Set SETUP = RC.Worksheets("Setup")
    Dim qPlace As VbMsgBoxResult
    Dim PN, PL, PLOC, LPLOC, CLLVL, TRLVL As String ' PartNumber | Prod Line | LineLoc | CL-Level | TR-Level
    Dim HAND, BIG, MOVE As Boolean 'Hand Hoist | Big Hoist | Moving into Racks
    Dim W, H, C, TRCL, MaxA_H, MaxB_H As Integer ' Width | Height | Columns | TR/CL | Max A-H | Max B-H
    Dim ACR, CCR As Integer 'Active Cell Row, Next Cell Row
    'Declarations for RouteConfiguration
    Dim DesigN, LocSec, LocLev As String
    Dim AOnly, pPlace As Boolean
    Dim A_W, B_W, A_H, B_H, SRCount, CALCCount, PCount, CCRstart As Integer
    
    On Error GoTo GetOutofHere
    PCount = 0
    CALCCount = 0
    
    CALC.Activate
    With CALC
        CCRstart = ActiveCell.Row
    End With
    MC.Activate
    With MC
    LPLOC = .Range("I" & ActiveCell.Row).Value
    PLOC = .Range("I" & ActiveCell.Row).Value
    End With
While PLOC = LPLOC And PCount < 40
    qPlace = vbNo
    Application.ScreenUpdating = False
    
    MC.Activate
    
    With MC
        ACR = ActiveCell.Row
        PN = .Range("C" & ACR).Value
        PL = .Range("D" & ACR).Value
        PLOC = .Range("I" & ACR).Value
        W = .Range("Y" & ACR).Value
        H = .Range("Z" & ACR).Value
        C = .Range("AB" & ACR).Value
        HAND = .Range("AK" & ACR)
        BIG = .Range("AL" & ACR)
        MOVE = .Range("AM" & ACR)
        CLLVL = .Range("AI" & ACR).Value
        TRLVL = .Range("AJ" & ACR).Value
        TRCL = .Range("AN" & ACR).Value
        MaxA_H = .Range("AO" & ACR).Value
        MaxB_H = .Range("AP" & ACR).Value
        pPlace = .Range("AR" & ACR)
    End With
        'MsgBox "CCRstart,LPLLOC,PLOC = " & CCRstart & " , " & LPLOC & " , " & PLOC & " , " & pPlace
        If PLOC <> LPLOC Or pPlace Then
            MsgBox "Part Has been placed or is the next cart!"
            Exit Sub
        End If
        If TRCL = "CL" Then
            LocLev = CLLVL
        ElseIf TRCL = "TR" Then
            LocLev = TRLVL
        Else
            MsgBox "There was an Error with TRCL from the PFEP"
        End If
            
        'MsgBox "The Variables are: " & PN & "," & PL & "," & PLOC & "," & W & "," & C & "," & BIG & "," & HAND & "," & MOVE & "," & CLLVL & "," & TRLVL & "," & TRCL & "," & MaxH & "!"
        
        While C > 0 And CALCCount < 200
            CALC.Activate
            While qPlace = vbNo And CALCCount < 200
                With CALC
                    CCR = ActiveCell.Row
                    LocSec = .Range("B" & CCR)
                    DesigN = .Range("D" & CCR)
                    AOnly = .Range("I" & CCR)
                    A_W = .Range("J" & CCR)
                    B_W = .Range("K" & CCR)
                    
                If TRCL = DesigN Then
                    If H < 96 Then
                        If LocLev = "A" And W < A_W + 1 And HAND = AOnly Then
                            qPlace = 6 'MsgBox("Do you want to place " & PN & " at " & LocSec & "." & LocLev & "?", vbYesNoCancel, "Place it") 'yes=6 'no=7 'cancel=2
                            If qPlace = vbYes Then
                                .Range("J" & CCR) = A_W - W
                                .Range("L" & CCR) = MaxA_H
                                pPlace = True
                            End If
                        ElseIf LocLev = "B" And W < B_W + 1 Then
                            qPlace = 6 'MsgBox("Do you want to place " & PN & " at " & LocSec & "." & LocLev & "?", vbYesNoCancel, "Place it") 'yes=6 'no=7 'cancel=2
                            If qPlace = vbYes Then
                                .Range("K" & CCR) = B_W - W
                                .Range("M" & CCR) = MaxB_H
                                pPlace = True
                            End If
                        End If
                    Else
                        GoTo GetOutofHere
                    End If
                End If
                If qPlace = vbNo Then
                    .Range("D" & CCR + 1).Activate
                End If
                End With
            CALCCount = CALCCount + 1
            Wend
            If qPlace = vbYes And CALCCount < 200 Then
                SETUP.Activate
                
                With SETUP
                    SRCount = .Range("A1").CurrentRegion.Rows.Count + 1
                    .Cells(SRCount, 1) = PN
                    .Cells(SRCount, 2) = PL
                    .Cells(SRCount, 3) = PLOC
                    .Cells(SRCount, 4) = W
                    .Cells(SRCount, 5) = H
                    .Cells(SRCount, 6) = C
                    .Cells(SRCount, 7) = LocSec & "." & LocLev
                End With
                
                MC.Activate
                With MC
                    C = C - 1
                    .Range("AR" & ACR) = pPlace
                    '.Range("AT" & ACR) = LocSec & "." & LocLev
                    If C = 0 Then
                        .Range("C" & ACR + 1).Activate
                    End If
                End With
            ElseIf qPlace = vbNo Then
            
            Else
                GoTo GetOutofHere
            End If
                    qPlace = vbNo
                    pPlace = False
        CALCCount = CALCCount + 1
    Wend
    Application.ScreenUpdating = True
    CALC.Activate
    CALC.Cells(CCRstart, 2).Select
    PCount = PCount + 1
Wend
    Application.ScreenUpdating = True
Exit Sub
GetOutofHere:
    MsgBox "There was an Error! " & Error$
            Application.ScreenUpdating = True
            qPlace = vbNo
            pPlace = False
End Sub

Sub X()
     
    Dim rngX, rngY, rngZ As Range
    Dim PartNumber, Kit, Location, L2 As String
    Dim W, A_W, B_W, URCount As Integer
     
        With Worksheets("Setup")
            Set rngX = ActiveCell
            If Not rngX Is Nothing Then
                'MsgBox "Found at " & rngX.Address
                PartNumber = .Range("A" & rngX.Row).Value
                Kit = .Range("C" & rngX.Row).Value
                W = .Range("D" & rngX.Row).Value
                Location = Left(Cells(rngX.Row, 7).Value, 7)
                L2 = Right(Cells(rngX.Row, 7).Value, 1)
                rngX.EntireRow.Delete
            End If
        End With
        With Worksheets("Calc")
            Set rngY = .Range("A1:B325").Find(Location, Lookat:=xlWhole)
            If Not rngY Is Nothing Then
                A_W = .Range("J" & rngY.Row).Value
                B_W = .Range("K" & rngY.Row).Value
                'MsgBox A_W & " , " & B_W & " , " & W
                If L2 = "A" Then
                    .Range("J" & rngY.Row) = A_W + W
                ElseIf L2 = "B" Then
                    .Range("K" & rngY.Row) = B_W + W
                End If
            End If
        End With
        With Worksheets("Undone")
            URCount = .Range("A1").CurrentRegion.Rows.Count + 1
            .Cells(URCount, 1) = Kit
        End With
        With Workbooks(1).Worksheets("MASTER CARTS")
            Set rngZ = .Range("C1:C1200").Find(PartNumber, Lookat:=xlWhole)
            .Range("AR" & rngZ.Row) = False
        End With

End Sub

Sub Macro3()
'
' Macro3 Macro
'
Dim GT As String

GT = InputBox("Greater Than #", "Filter By Number")

    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[Designation]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[Com. order]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveSheet.ListObjects("Table27").Range.AutoFilter Field:=10, Criteria1:= _
        ">" & GT, Operator:=xlAnd

End Sub

Sub Macro6()
'
' Macro6 Macro
'
Dim GT2 As String

GT2 = InputBox("Greater Than #", "Filter By Number")

    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[Designation]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[Com. order]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveSheet.ListObjects("Table27").Range.AutoFilter Field:=11, Criteria1:= _
        ">" & GT2, Operator:=xlAnd

End Sub

Sub Macro7()
'
' Macro7 Macro
'
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[[#All],[Shelf Order]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Sub Macro8()
'
' Macro8 Macro
'

'
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort.SortFields.Add _
        Key:=Range("Table27[[#All],[Designation]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Calc").ListObjects("Table27").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.ListObjects("Table27").Range.AutoFilter Field:=10, Criteria1:= _
        ">15", Operator:=xlAnd
End Sub

Sub Macro9()
'
' Macro9 Macro
'
Dim R1 As Integer
Dim R2 As Integer

    R2 = 2
While R1 < 325
    R1 = Selection.Row
    Cells(R1, 2).Select
    Selection.Copy
    Range(Cells(R2, 9), Cells(R2 + 2, 9)).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Cells(R1 + 1, 1).Select
    R2 = R2 + 2
Wend
End Sub