Ton of script in case anyone wants to review, maybe something useful to someone

cizzett

Board Regular
Joined
Jan 10, 2019
Messages
121
Maybe something in here can be useful to someone maybe someone wants to critique.

Workbook scripts:
Code:
' 03/2019' This workbook created




Private Sub Workbook_Open()


' -------------Quick scroll to remove any date picker shadowing---------------
        ActiveWindow.SmallScroll Down:=-15
   ' Check to see if macro has already been run today
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Sheets("Today")
Dim HideCB As CheckBox: Set HideCB = Ws.Shapes("HideCB").OLEFormat.Object
    If Ws.Range("F1") > 1 Then
     Exit Sub
    Else
''''''''    GettingStarted.Show
Dim Msg As String, Ans As Variant
    Msg = "1-Export QLTY data from JDA to designated file" _
    & vbNewLine & "2-Open SAP and ensure active window" _
    & vbNewLine & "3-If file exported and SAP window active" _
    & vbNewLine & " " _
    & vbNewLine & "Yes to begin" _
    & vbNewLine & " " _
    & vbNewLine & "No to open without importing" _
    & vbNewLine & " " _
    & vbNewLine & "Cancel to abort and close"
        Ans = MsgBox(Msg, vbYesNoCancel + vbExclamation, "Before Proceeding")
         Select Case Ans
            Case vbYes: Call ImportBndle
            Case vbno
             Case vbCancel: ActiveWorkbook.Close savechanges:=False
             End Select
      End If
    
    If HideCB.Value = 1 Then
Ws.Rows("1:1").EntireRow.Hidden = True
Ws.Shapes("Tool Bar").Visible = False
Else
    If Ws.Rows("1:1").EntireRow.Hidden = True Then
Ws.Rows("1:1").EntireRow.Hidden = False
Ws.Shapes("Tool Bar").Visible = True
Ws.Shapes("Tool Bar").Top = 9
Ws.Shapes("Tool Bar").Left = 3
End If
End If
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)


Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Sheets("Today")
Set Fl = Wb.Sheets("File Locs")
            Set ASCB = Fl.Shapes("ASCB").OLEFormat.Object
        If Ws.Range("E3") = 0 Then
            ThisWorkbook.Saved = True
                Exit Sub
        End If
            If ASCB.Value = 1 Then


Dim Msg As String, Ans As Variant


Msg = "Yes: Update the running file, save changes, and exit WorkBook" _
        & vbNewLine & "" _
        & vbNewLine & "No: Close without updating or saving" _
        & vbNewLine & "" _
        & vbNewLine & "Cancel: Keep Workbook open"
        Ans = MsgBox(Msg, vbYesNoCancel + vbExclamation, "Before Closing")
         Select Case Ans
            Case vbYes: Call UpdateRun
            Case vbno: ThisWorkbook.Saved = True
                Exit Sub
             Case vbCancel: Cancel = True
             End Select
        End If


End Sub


Private Sub Workbook_BeforePrint(Cancel As Boolean)


Application.ScreenUpdating = False
Application.EnableEvents = False


Dim LastPage As Long, PageNumber As Long
LastPage = ExecuteExcel4Macro("Get.Document(50)")
ActiveSheet.PageSetup.LeftFooter = ""
If LastPage > 1 Then
ActiveSheet.PrintOut From:=1, To:=LastPage - 1
End If
ActiveSheet.PageSetup.LeftFooter = "Verified by:____________________________________  Date:_________________"
ActiveSheet.PrintOut From:=LastPage, To:=LastPage
ActiveSheet.PageSetup.LeftFooter = ""
Application.EnableEvents = True
Application.ScreenUpdating = True
Cancel = True
End Sub

Main Scripts:
Code:
Option Explicit'-----Defines variable for use accross all script in module----------
Public Wb As Workbook   'Defines this workbook
Public df As Workbook   'Defined in Script
Public Pd As Workbook   'Defined in Script
Public mf As Workbook   'Defined in Script
Public Wbk As Workbook  'Defined in Script


'-----------Defines Worksheets--------------------------
Public Ws As Worksheet      'Today Sheet
Public Ls As Worksheet      'Lot Worksheet
Public Fl As Worksheet      'File Lpocations Sheet
Public Ps As Worksheet      'Previous Day Sheet
Public Es As Worksheet      'Email Sheet
Public SOS As Worksheet     'SOS Source of Supply Sheet
Public Piv As Worksheet     'Pivot Table Sheet
Public Inst As Worksheet    'Instructions Sheet
Public ds As Worksheet      'Defined in Script
Public Pds As Worksheet     'Defined in Script
Public ms As Worksheet      'Defined in Script
Public Nws As Worksheet     'Defined in Script
Public RDPiv As Worksheet   'Defined in Script


'------Define Tables-----------------------------------
Public TT As ListObject     'Today Table
Public PDPT As ListObject   'Previous Day Table
Public PDT As ListObject    'Defined in Script----Table from previous day file to be imported
Public SOSMT As ListObject   'Defined in Script-----SOS Master File Table to import from
Public SOSDT As ListObject  'SOS File on SOS Sheet
Public LT As ListObject     'Lot Table
Public ET As ListObject     'Email Table
Public RDT As ListObject    'Running Year Data Table-Set in script


'-----Define "Run/No-Run" Checkboxes-------------------
Public IPCB As CheckBox     'Choose to import Previous Days Data
Public SOSCB As CheckBox    'Choose to import SOS
Public LPCB As CheckBox     'Choose to Auto-Print Lot Sheet
Public RFCB As CheckBox     'Choose to export to Running File
Public ASCB As CheckBox     'Choose to use Auto Save Promt
Public SAPCB As CheckBox    'Choose to run data through SAP
Public ASSCB As CheckBox    'Turn Status auto sort on and off
Public HideCB As CheckBox    'Hide or Unhide Row One


'------Define "Was Run" Checkboxes---------------------
Public SOSRunCB As CheckBox     'SOS was run
Public JDARunCB As CheckBox     'JDA File was imported
Public PDRunCB As CheckBox      'Previous Day file was imported
Public PLWSRunCB As CheckBox    'Print Lot WS run
Public ExPRunCB As CheckBox     'FIle was exported to running file
Public ASRunCB As CheckBox      'Austo Save was run
Public SAPRunCB As CheckBox     'SAP was run


'---------------------Creat table ranges as variable-----------------------
Public ETR As Range     'Whole EmailTable Range


Public TTC1 As Range    'Key
Public TTC2 As Range    'Status
Public TTC3 As Range    'Cause
Public TTC4 As Range    'Storage Location
Public TTC7 As Range    'SAP Item #
Public TTC8 As Range    'SAP PO#
Public TTC15 As Range   'SAP MFG
Public TTC16 As Range   'SAP EXP
Public TTC17 As Range   'Label Mfg
Public TTC18 As Range   'Label EXP
Public TTC19 As Range   'SOS
Public TTC20 As Range   'Comments
Public TTC21 As Range   'Contact
Public TTC22 As Range   'MRP Email


Sub Dec()
'----------Set Values for Module--------------------------


'------------Set Workbook and Sheets--------------------
Set Wb = ThisWorkbook
Set Ws = Wb.Sheets("Today")
Set Ls = Wb.Sheets("L.W.S.")
Set Fl = Wb.Sheets("File Locs")
Set Ps = Wb.Sheets("Prev Day")
Set Es = Wb.Sheets("E-mail")
Set Piv = Wb.Sheets("Pivot")
Set Inst = Wb.Sheets("Instruction Sheet")
Set SOS = Wb.Sheets("SOS")


'---------------Set Tables--------------------------
Set PDT = Ps.ListObjects("PD_Table")
Set TT = Ws.ListObjects("TodayTable")
Set LT = Ls.ListObjects("LotTable")
Set ET = Es.ListObjects("EmailTable")
Set SOSDT = SOS.ListObjects("SOSDT")


'------Set CheckBoxes for run script checks-----------
Set IPCB = Fl.Shapes("IPCB").OLEFormat.Object
Set SOSCB = Fl.Shapes("SOSCB").OLEFormat.Object
Set LPCB = Ws.Shapes("LPCB").OLEFormat.Object
Set RFCB = Fl.Shapes("RFCB").OLEFormat.Object
Set ASCB = Fl.Shapes("ASCB").OLEFormat.Object
Set SAPCB = Fl.Shapes("SAPCB").OLEFormat.Object
Set ASSCB = Ws.Shapes("ASSCB").OLEFormat.Object
Set HideCB = Ws.Shapes("HideCB").OLEFormat.Object


'---------Set Checkboxes showing script was run--------------
Set SOSRunCB = Ws.Shapes("SOSRunCB").OLEFormat.Object
Set JDARunCB = Ws.Shapes("JDARunCB").OLEFormat.Object
Set PDRunCB = Ws.Shapes("PDRunCB").OLEFormat.Object
Set PLWSRunCB = Ws.Shapes("PLWSRunCB").OLEFormat.Object
Set ExPRunCB = Ws.Shapes("ExPRunCB").OLEFormat.Object
Set ASRunCB = Ws.Shapes("ASRunCB").OLEFormat.Object
Set SAPRunCB = Ws.Shapes("SAPRunCB").OLEFormat.Object
'-------------Name table ranges---------------
Set ETR = Range("EmailTable[#All]").Resize(12, 1)
Set TTC1 = TT.DataBodyRange(1, 1)
Set TTC2 = TT.DataBodyRange(1, 2)
Set TTC3 = TT.DataBodyRange(1, 3)
Set TTC4 = TT.DataBodyRange(1, 4)
Set TTC7 = TT.DataBodyRange(1, 7)
Set TTC8 = TT.DataBodyRange(1, 8)
Set TTC15 = TT.DataBodyRange(1, 15)
Set TTC16 = TT.DataBodyRange(1, 16)
Set TTC17 = TT.DataBodyRange(1, 17)
Set TTC18 = TT.DataBodyRange(1, 18)
Set TTC19 = TT.DataBodyRange(1, 19)
Set TTC20 = TT.DataBodyRange(1, 20)
Set TTC21 = TT.DataBodyRange(1, 21)
Set TTC22 = TT.DataBodyRange(1, 22)


End Sub


 Sub Row1Hide_*******()
 Call Row1Hide
   End Sub
   
   
Sub Row1Hide()
   Call Dec
If HideCB.Value = 1 Then
Ws.Rows("1:1").EntireRow.Hidden = True
Ws.Shapes("Tool Bar").Visible = False
Else
Ws.Rows("1:1").EntireRow.Hidden = False
Ws.Shapes("Tool Bar").Visible = True
Ws.Shapes("Tool Bar").Top = 9
Ws.Shapes("Tool Bar").Left = 3
End If
   End Sub
      
Sub ImportBndle()
'----This bundles all scripts to import data from JDA Export and run through SAP--------------------------
        PrevRptDate.PrevDTPicker.Value = CDate(Evaluate("WORKDAY(TODAY(),-1)"))
        PrevRptDate.Show 'User Form to start import and select previous report date
        WaitingMsg.Show
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
 '----------------------Call scripts in order---------------------------------
    Call Dec 'Calls up the declarations used for script
    Call ImportPrevious
    Call updateSOS
    Call ImportAllData
    Call ReadBatch
        ActiveWorkbook.RefreshAll
    Call GetPD
    Call GetSource
        ActiveWorkbook.RefreshAll
    Call MarkNew ' Script to mark new record automatically as "New"
    Call StatusSort
    Call SaveFinal
       Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        ASSCB.Value = True
    Unload WaitingMsg
    Call Hidesome
End Sub


Sub EmailBundle()


'-----------------This bundles script for creating email templates--------------------
 Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Call Dec 'Calls up the declarations used for script
    Call UnhideAll
        Call Hidesome
'------------- Filter table to new records only-------------------------------
        With TT.DataBodyRange
        .AutoFilter 2, "New"
          If TT.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
    Call PrepEmail
    Range("B12").Select
Else
    TT.AutoFilter.ShowAllData
   MsgBox "No new records detected"
   End If
   
    End With
     Call RemoveFrmls
    Application.DisplayAlerts = True
        Application.ScreenUpdating = True
End Sub


Sub FinalizeBundle()


Call Dec 'Calls up the declarations used for script


'------------Check Msg to verify if the user is ready to proceed
Dim Msg As String, Ans As Variant
    Msg = "Please fill in columns B, C, and G fully." _
    & vbNewLine & "" _
    & vbNewLine & "Cancel to go back and finish filling in data" _
    & vbNewLine & "" _
    & vbNewLine & "OK to continue"
      Ans = MsgBox(Msg, vbOKCancel)
   Select Case Ans
        Case vbOK
         Case vbCancel: GoTo Quit:
         End Select
         
'-----If user chooses to continue--------------------
     WaitingMsg.Show
        Application.DisplayAlerts = False
       Application.ScreenUpdating = False
   
            Call UpdateRun
        Call UnhideAll
        Call RemoveFrmls
        Call Prep
               Ws.Activate
      TT.ShowAutoFilterDropDown = False
    Unload WaitingMsg
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
'----------If user chooses not to continue-----------------------
Quit:
End Sub


Sub LotBundle()


'----------------This bundles the scripts to create the Lot Worksheet----------------------
    Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Call Dec 'Calls up the declarations used for script
    Call Hidesome
 
'-----------This Filters table to new records only-----------------------------------
        With TT.DataBodyRange
        .AutoFilter 2, "New"
          If TT.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
    Call LotWSPrep
  Else
'--------If no new records exist to research----------------------------------
    TT.AutoFilter.ShowAllData
        MsgBox "No new records to export to runnning file"
      End If
    End With
        Application.DisplayAlerts = True
       Application.ScreenUpdating = True
End Sub


Sub ImportAllData()


            Ws.Range("F1") = Date
'------------------This section Arranges Columns Properly in Source File-----------------------------
    Set df = Workbooks.Open(Fl.Range("B4").Value)
    Set ds = df.ActiveSheet
    
    Dim search As Range
     Dim cnt As Integer
       Dim colOrdr As Variant
         Dim indx As Integer
    ds.Activate
'------------This script defines column order with header names here------------
colOrdr = Array("Storage Location", "Item Number", "Lot Number" _
        , "Inventory Status", "Load Number", "Manufactured Date" _
        , "Expiration Date", "Received Date", "Unit Quantity" _
        , "Description")
            cnt = 1
            
'-------------This section re-orders the columns in the source file---------------
For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, lookat:=xlWhole, _
    SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not search Is Nothing Then
        If search.Column <> cnt Then
            search.EntireColumn.Cut
            Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    cnt = cnt + 1
    End If
Next indx
    df.Save
    
'------------------This section removes duplicates not needed for report-----------------------------
    ds.Range("E2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    Selection.TextToColumns Destination:=Range("E2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 9), Array(10, 1)), TrailingMinusNumbers:=True
    ds.Range("$A$1:$AJ" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
    
'----------------------- Sorts source data before import-------------
    ds.Sort.SortFields.Clear
    ds.Sort.SortFields.Add Key:=Range("I1"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ds.Sort
        .SetRange Range("A2:K" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'-------------- This section copies the data and pastes into the Workbook--------------
    ds.Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
    Ws.Range("D3").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ds.Range("E2:J" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        Ws.Range("I3").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        df.Close savechanges:=False
        JDARunCB.Value = True
    Exit Sub
    
ErrHandler:
  Dim Msg As String, Ans As Variant
    Msg = "A fatal error has occured:" _
           & vbNewLine & "" _
           & vbNewLine & "Verify file address and name are correct on File Locs sheet."
If MsgBox(Msg, vbOK) = vbOK Then End


 JDARunCB.Value = True
End Sub


Sub ImportPrevious()


'-------------If use box is checked-Imports the previous days data for reference--------------------------------
              If IPCB.Value = 1 Then
              Else: GoTo Skip:
                End If
            Application.EnableEvents = False      '-------------Supress Macros on prev day workbook
'--------------------------- Set and open file-----------------------------------------------------
        Set Pd = Workbooks.Open(Fl.Range("B21").Value)
          Set Pds = Pd.Sheets("Today")
       Set PDPT = Pds.ListObjects("TodayTable")
       
'------------------- Unhide all rows and columns in previous days file-----------------------------
                Pds.Columns.EntireColumn.Hidden = False
                Pds.Rows.EntireRow.Hidden = False
                
'------------------------- Copy and Paste Data to file---------------------------------------------
        PDPT.DataBodyRange.Copy
    PDT.DataBodyRange.PasteSpecial Paste:=xlPasteValues
   Pd.Close savechanges:=False
   Application.EnableEvents = True   '-------------Enable Macros in Prev Day Workbook
   Ws.Activate
    ActiveWorkbook.RefreshAll
   PDRunCB.Value = True
'-----------If checkbox is unchecked------------------------
Skip:
End Sub


Sub MarkNew()


    Dim LastRow As Long, rng As Range
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each rng In Range("D2:D" & LastRow)
        If rng <> "" And rng.Offset(0, 13) = "" And rng.Offset(0, 14) = "" And rng.Offset(0, 16) = "" Then
            rng.Offset(0, -2) = "New"
        End If
    Next rng
   
End Sub


Sub StatusSort()


'-------------Status Sort------------------------------------
        With TT.Sort
        .SortFields.Clear
        .SortFields.Add Key:=TTC19, SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
'-------------SOS Sort------------------------------------
    With TT.Sort
        .SortFields.Clear
        .SortFields.Add Key:=TTC2, SortOn:=xlSortOnValues, Order:=xlAscending _
        , CustomOrder:="New,Waiting on response,Resolved,Non-Batch" _
        , DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
    
End Sub


Sub updateSOS()
            Call Dec
'---------------Checks if the use checkbox is checked----------
              If SOSCB.Value = 1 Then
              Else: GoTo Skip:
                End If


  ' -------This finds the file address, and opens the file for SOS Master sheet---
     On Error GoTo ErrHandler
    Set mf = Workbooks.Open(Fl.Range("B26").Value)
     Set ms = mf.Sheets("SOS-M")
        
        '----------------- Set Table from master file-------------------------------------------
        Set SOSMT = ms.ListObjects("SOS_Table")
        Application.DisplayAlerts = False
               
' ----------This section copies the data and pastes into the Workbook------------
      SOSMT.DataBodyRange.Copy _
      Destination:=SOSDT.DataBodyRange
      SOSDT.ShowAutoFilterDropDown = False
      
      mf.Close savechanges:=False
      Application.CutCopyMode = False
       SOSRunCB.Value = True
    Exit Sub
'----------This handles errors with a message and options------------------------------
ErrHandler:
    Dim Msg As String, Ans As Variant
    Msg = "SOS Failed to Update, Check FIle Address and Name on File Locs Sheet" _
    & vbNewLine & "" _
    & vbNewLine & "OK to continue without updating SOS" _
    & vbNewLine & "" _
    & vbNewLine & "Cancel to exit."
Ans = MsgBox(Msg, vbOKCancel)
    Select Case Ans
        Case vbOK: GoTo Skip:
        Case vbCancel: End
        End Select
        
'--------If use checkbox is unchecked or error and cancel selected-------------
Skip:
End Sub


Sub CloseWS()
'-------------Used to close "Current Active" Worksheet-----------------
    ActiveSheet.Visible = False
    On Error Resume Next
        Ws.Activate
        Range("D3").Select
End Sub


Sub UnhideAll()
     Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
End Sub


Sub PrepEmail()


    ' Unhides the Email Worksheet
        Es.Visible = True
            Es.Activate
'-------------------- Deletes any data prior to pulling data in-----------------
                Es.Range("C:Z").Delete
            ET.DataBodyRange.ClearContents
                 ET.Resize ETR
                 
'-------------- Filters to new records and copies and pastes data to the E-mail worksheet----------
With TT.DataBodyRange
        .AutoFilter 2, "New"
        TT.DataBodyRange.Columns("E:H").Offset(0).SpecialCells(xlVisible).Copy
'-------------------- Pastes transposed data into email sheet------------------------
        Es.Range("B2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
            TT.DataBodyRange.Columns("O:P").Offset(0).SpecialCells(xlVisible).Copy
             Es.Range("B7").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
                   TT.DataBodyRange.Columns("Q:S").Offset(0).SpecialCells(xlVisible).Copy
                Es.Range("B10").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
                   False, Transpose:=True
                       TT.DataBodyRange.Columns("U").Offset(0).SpecialCells(xlVisible).Copy
                    Es.Range("B13").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
                       False, Transpose:=True
'--------------------------- Unhides E-mail Worksheet------------------------------------------------
   Es.Visible = True
        .AutoFilter
    Es.Activate
    End With
    ' sets column widths etc for worksheet
     ET.DataBodyRange.Interior.Color = xlNone
     ET.DataBodyRange.Font.Color = xlThemeColorLight1
             
        Es.Range("B6").Select
        Intersect(ActiveCell.EntireRow, ET.DataBodyRange).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
                    
        Es.Range("B9").Select
        Intersect(ActiveCell.EntireRow, ET.DataBodyRange).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
    Es.Cells.Select
    Cells.EntireColumn.ColumnWidth = 18.43
    Selection.HorizontalAlignment = xlLeft
    Application.CutCopyMode = False
  ET.ShowAutoFilterDropDown = False
End Sub


Sub LotWSPrep()


'--------Make L.W.S. Visible and Active----------------------
    Ls.Visible = True
            Ls.Activate
            
        ' Deletes any data prior to pulling data in
        On Error Resume Next
        Ls.Rows("2:1000").Delete Shift:=xlUp
        
'--------------Filter Today Table to new and paste data to L.W.S.--------------
With TT.DataBodyRange
        .AutoFilter 2, "New"
        Union(.Columns("D:F"), .Columns("I"), .Columns("O:P")).Offset(0).Copy
        Ls.Range("A2").PasteSpecial xlValues
        .AutoFilter
    End With


   ' ----------------Sort Lot Worksheet--------------
     Range("A1").Sort Key1:=Range("A2"), _
      Order1:=xlAscending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
      
'----------------Decide whether to Print or View the Lot Worksheet---------
        If LPCB.Value = 1 Then
        Else: GoTo Skip:
        End If
        Dim Msg As String, Ans As Variant
Msg = "Do you want to print the Lot WorkSheet?" _
    & vbNewLine & "" _
    & vbNewLine & "Yes to print" _
    & vbNewLine & "" _
    & vbNewLine & "No to cancel and preview."
    Ans = MsgBox(Msg, vbYesNo)
     Select Case Ans
        Case vbYes
         Case vbno: GoTo Skip:
         End Select
    LT.Range.PrintOut
    PLWSRunCB.Value = True
Ls.Visible = False
Skip:
    Range("A2").Select
End Sub


Sub Prep()
     
' Resize and hide columns
Ws.Activate
    Columns("A:A").ColumnWidth = 5
    Columns("M:N").Hidden = True
    Columns("V:X").Hidden = True
    Columns("T:T").ColumnWidth = 50.57
        Range("B3").Select
    Ws.Sort.SortFields.Clear
    Ws.Sort.SortFields.Add Key:=Range("B3:B62"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "New,Waiting on response,Resolved,Non-Batch", DataOption:=xlSortNormal
    With Ws.Sort
        .SetRange Range("A2:X62")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        
'--------This hides row 1 on Todays data tab including form control buttons--------
  Ws.Rows("1:1").EntireRow.Hidden = True
Ws.Shapes("Tool Bar").Visible = False
HideCB.Value = True
'------------------- Hide sheets before distributing---------------
    Inst.Visible = False
    Ls.Visible = False
    Es.Visible = False
    Fl.Visible = False
    Ps.Visible = False
    SOS.Visible = False
'--------------Clear Contents of SOS Sheet--------------
         SOSDT.DataBodyRange.ClearContents
'--------------Delete all table rows except first in SOS-------------------------
 
  SOSDT.DataBodyRange.ClearContents
'-------------------Filter out blanks on Pivot Tables-----------------------
        Piv.Activate
         ActiveWorkbook.RefreshAll
    On Error Resume Next
     Piv.PivotTables("PivotTable5").PivotFields("Legacy Item #"). _
      ClearAllFilters
    With Piv.PivotTables("PivotTable5").PivotFields("Legacy Item #")
        .PivotItems("(blank)").Visible = False
    End With
        Piv.PivotTables("PivotTable1").PivotFields("SOS").ClearAllFilters
    With Piv.PivotTables("PivotTable1").PivotFields("SOS")
        .PivotItems("").Visible = False
    End With
        ActiveWorkbook.RefreshAll
    End With
End Sub




Sub Hidesome()
'------------------ HideColumns Macro---------------------
    Ws.Activate
  Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
       Range("M:N,W:X").EntireColumn.Hidden = True
        Range("A:A").ColumnWidth = 5
            Range("D3").Select
End Sub


Sub SaveFinal()


'----------This gets desired file location and name then saves the files--------------
     Dim FP As String: FP = Fl.Range("B15").Value
      Dim FN As String: FN = Fl.Range("B14").Value
       Dim Fll As String: Fll = Fl.Range("B12").Value
        Dim FF As String: FF = Fl.Range("B13").Value
     If ASCB.Value = 1 Then


'------------This finds save location and file name then shows Message before saving-------------
          Dim Msg As String, Ans As Variant
          Msg = "You are about to save the file to: " & Fll & "\" & FF _
                & vbNewLine & "" _
                & vbNewLine & "As File Name:" & " " & FN _
                & vbNewLine & "To Save press Yes" _
                & vbNewLine & "" _
                & vbNewLine & "Otherwise Press No"
    Ans = MsgBox(Msg, vbYesNo)
     Select Case Ans
        Case vbYes
         Case vbno: GoTo Quit:
         End Select


        On Error GoTo ErrHandler:
        Application.DisplayAlerts = True
  ThisWorkbook.SaveAs Filename:=FP, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        Application.DisplayAlerts = False
  End If
'-----------Check Box on Today Sheet----------------
      ASRunCB.Value = True
  Exit Sub


ErrHandler:
  MsgBox "File Name Already Exists or a fatal error has occured"
Quit:
End Sub


Sub RTT()


                Dim Msg As String, Ans As Variant
    Msg = "Do you wish to reset workbook and import new-data?" _
    & vbNewLine & " " _
    & vbNewLine & "Yes - Reset this workbook & Import Data" _
    & vbNewLine & " " _
    & vbNewLine & "No - Reset workbook only" _
    & vbNewLine & " " _
    & vbNewLine & "Cancel - Exit without making changes"
    Ans = MsgBox(Msg, vbYesNoCancel + vbQuestion, "Reset WorkBook?")
            Select Case Ans
            Case vbYes
            Case vbno: Call Reset: Exit Sub
            Case vbCancel: GoTo Cancel
            End Select
        Call Dec
'----------- This resets the Today Table on the Today Sheet----------------------
    TT.DataBodyRange.ClearContents
'--------------Delete all table rows except first row--------------------------
  With TT.DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
  End With
     Ws.Range("F1:H1").ClearContents
    PDT.DataBodyRange.ClearContents


'----------------Re-Insert the formulas into today table----------------------------
        TTC1.Formula = "=E3&""-""&F3"


      Call ImportBndle
Cancel:
End Sub


Sub Reset()
        Call Dec
'----------- This resets the Today Table on the Today Sheet----------------------
    TT.DataBodyRange.ClearContents
'--------------Delete all table rows except first row--------------------------
  With TT.DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
  End With
    Call updateSOS
    Call UnhideAll
     Ws.Range("F1:H1").ClearContents
    PDT.DataBodyRange.ClearContents
    Inst.Visible = xlSheetVisible
    Fl.Visible = xlSheetVisible
            IPCB.Value = True
              SOSCB.Value = True
                LPCB.Value = True
                 RFCB.Value = True
                     ASCB.Value = True
                       SAPCB.Value = True
                         ASSCB.Value = False
                      SOSRunCB.Value = False
                    JDARunCB.Value = False
                  PDRunCB.Value = False
                PLWSRunCB.Value = False
               ExPRunCB.Value = False
              ASRunCB.Value = False
             SAPRunCB.Value = False
            HideCB.Value = False
    '----------------Re-Insert the formulas into today table----------------------------
        TTC1.Formula = "=E3&""-""&F3"
       Ws.Activate
       ActiveWindow.ScrollColumn = 1
        Ws.Range("D3").Select
        ActiveWorkbook.RefreshAll
End Sub
Sub RefreshPivotData()
   ActiveWorkbook.RefreshAll
End Sub


Sub RemoveFrmls()


'--------------Unhide all columns------------------
        Cells.EntireColumn.Hidden = False
        
'-------Remove Formulas from "TodayTable"----------
        TT.DataBodyRange.Value = TT.DataBodyRange.Value
End Sub


Sub RemoveZeros()


'---------------RemoveZeros Macro from pivot table------------------------
    Piv.Select
    With Piv.PivotTables("PivotTable5").PivotFields("Legacy Item #")
        .PivotItems("(blank)").Visible = False
    End With
    With Piv.PivotTables("PivotTable1").PivotFields("SOS")
        .PivotItems("").Visible = False
    End With
    Ws.SelectRange("D3").Select
End Sub


Sub GetPD()
    Application.ScreenUpdating = False
    Dim Val As String, ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Today")
    Set ws2 = Sheets("Prev Day")
    Dim i As Long, v1, v2
    v1 = ws1.Range("A3", ws1.Range("A" & Rows.Count).End(xlUp)).Resize(, 20).Value
    v2 = ws2.Range("A3", ws2.Range("A" & Rows.Count).End(xlUp)).Resize(, 20).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v2, 1)
            Val = v2(i, 1)
            If Not .Exists(Val) Then
                .Add Val, i + 2
            End If
        Next i
        For i = 1 To UBound(v1, 1)
            Val = v1(i, 1)
            If .Exists(Val) Then
                ws1.Cells(i + 2, "b") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "b")
                ws1.Cells(i + 2, "c") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "c")
                ws1.Cells(i + 2, "H") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "H")
                ws1.Cells(i + 2, "Q") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "Q")
                ws1.Cells(i + 2, "R") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "R")
                ws1.Cells(i + 2, "T") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "T")
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub


Sub GetSource()
    Application.ScreenUpdating = False
    Dim Val As String, ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Today")
    Set ws2 = Sheets("SOS")
    Dim i As Long, v1, v2
    v1 = ws1.Range("G3", ws1.Range("G" & Rows.Count).End(xlUp)).Resize(, 26).Value
    v2 = ws2.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v2, 1)
            Val = v2(i, 1)
            If Not .Exists(Val) Then
                .Add Val, i + 2
            End If
        Next i
        For i = 1 To UBound(v1, 1)
            Val = v1(i, 1)
            If .Exists(Val) Then
                ws1.Cells(i + 2, "S") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "E")
                ws1.Cells(i + 2, "U") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "F")
                ws1.Cells(i + 2, "V") = ws2.Cells(ws2.Range("A:A").Find(Val).Row, "G")
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub


Sub UpdateRun()
    Application.ScreenUpdating = False
             Call Dec
    If Ws.Range("E3") > 0 Then
    
            Set Wbk = Workbooks.Open(Fl.Range("B9").Value)
            Set Nws = Wbk.Sheets("Data")
            Set RDPiv = Wbk.Sheets("Pivot")
    Dim path As String, Val As String, i As Long, v1, v2
                
'----------------------------Update status, cause, and comments for current records---------------------------
 v1 = Ws.Range("A3", Ws.Range("A" & Rows.Count).End(xlUp)).Value
   v2 = Nws.Range("A3", Nws.Range("A" & Rows.Count).End(xlUp)).Value
   With CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(v2, 1)
          Val = v2(i, 1)
          If Not .Exists(Val) Then
              .Add Val, i + 2
          End If
      Next i
      For i = 1 To UBound(v1, 1)
         Val = v1(i, 1)
         If .Exists(Val) Then
             Nws.Cells(.Item(Val), "B") = Ws.Cells(i + 2, "B")
             Nws.Cells(.Item(Val), "C") = Ws.Cells(i + 2, "C")
             Nws.Cells(.Item(Val), "T") = Ws.Cells(i + 2, "T")
         Else
           Nws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 24).Value = Ws.Range("A" & i + 2).Resize(, 24).Value
         End If
      Next i
   End With
    '-----------------Refresh's Pivot table data-----------------------
   RDPiv.Activate
   ActiveWorkbook.RefreshAll
      Wbk.Close True
    Wb.Save
    End If
    Wb.RefreshAll
    Application.ScreenUpdating = True
    ExPRunCB.Value = True


    End Sub

TodaySheet:
Code:
Private Sub StatusSort_Click()    
   ActiveWorkbook.Worksheets("Today").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Today").Sort.SortFields.Add Key:=Range("B3:B500"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "New,Waiting on response,Resolved,Non-Batch", DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Today").Sort
        .SetRange Range("A2:X500")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        
        End With
End Sub


Private Sub WorkSheet_Change(ByVal Target As Range)
     
     If Not Intersect(Target, Range("B:B")) Is Nothing Then
     Else: GoTo Skip:
     End If
     Application.ScreenUpdating = False
    Dim Ws As Worksheet: Set Ws = ThisWorkbook.Sheets("Today")
    Dim ASSCB As CheckBox: Set ASSCB = Ws.Shapes("ASSCB").OLEFormat.Object
    Dim TT As ListObject: Set TT = Ws.ListObjects("TodayTable")
    Dim StatusS As Range: Set StatusS = Range("TodayTable[Status]")
    Dim SOSS As Range: Set SOSS = Range("TodayTable[SOS]")
    
        If ASSCB.Value = 1 Then
                      Else: GoTo Skip:
                        End If
'-------------Status Sort------------------------------------
        With TT.Sort
        .SortFields.Clear
        .SortFields.Add Key:=SOSS, SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
'-------------SOS Sort------------------------------------
    With TT.Sort
        .SortFields.Clear
        .SortFields.Add Key:=StatusS, SortOn:=xlSortOnValues, Order:=xlAscending _
        , CustomOrder:="New,Waiting on response,Resolved,Non-Batch" _
        , DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
    Application.ScreenUpdating = True
Skip:
End Sub

EmailSheet:
Code:
Private Sub WorkSheet_Change(ByVal Target As Range)     If Not Intersect(Target, Range("B:B")) Is Nothing Then
       Sheets("E-Mail").Range("B12").Select
     End If
End Sub

GUI Script (Mass Read SAP):
Code:
Option Explicit'=================================================================================
' VBA for running the MSC3N transaction
'
' History
' 
'=================================================================================


'
' Constants which provide layout for the spreadsheet columns
'
Const ColMatnr As Integer = 5   'Material Number column
Const ColBatch As Integer = 6   'Batch column
Const ColMfgDate As Integer = 15 'DOM column
Const ColSLED As Integer = 16    'SLED column
Const ColSAPMatnr As Integer = 7   'SAP Material Number
Const ColResult As Integer = 24  'Results Column




'----------------------------------------------------------------------------------------------------
' Read Batch button runs the following subroutine.
'
'----------------------------------------------------------------------------------------------------
Public Sub ReadBatch()


Restart:
'------------Check for checkbox selection on file locations worksheet------------------------------


             If SAPCB.Value = 1 Then
                Else: GoTo Skip:
                End If
'-------------------------------------------------------------------------
      ' All the SAP objects we need to connect and run a script
    Dim App As Variant                   ' SAP application
    Dim SAPGuiAuto As Variant            ' SAP GUI
    Dim Connection As Variant            ' Connection to SAP GUI
    Dim Session As Variant               ' Session with SAP
    Dim WScript As Variant               ' SAP Scripting
           
    On Error GoTo ErrHandler
          
    '
    ' Setup connnection to SAP GUI
    '
    If Not IsObject(App) Then
     Set SAPGuiAuto = GetObject("SAPGUI")
     Set App = SAPGuiAuto.GetScriptingEngine
    End If
    If Not IsObject(Connection) Then
     Set Connection = App.Children(0)
    End If
    If Not IsObject(Session) Then
     Set Session = Connection.Children(0)
    End If
    If IsObject(WScript) Then
     WScript.ConnectObject Session, "on"
     WScript.ConnectObject App, "on"
    End If
     
    Set SAPGuiAuto = Nothing
    Set App = Nothing
    Set Connection = Nothing
    Set WScript = Nothing
    
    '
    ' Loop through the information in the spreadsheet to read batch information using MSC3N transaction.
    ' The loop will stop when we find an empty (i.e., not blank) Material number
    '
    Dim DOM, SLED As String   ' Information read back on MSC3N to be written to the spreadsheet
    Dim SSBatch As String               ' Batch as read from the spreadsheet
    Dim SSMatnr As String               ' Material number read from spreadsheet
    Dim SAPMatnr As String              ' The SAP material number
    Dim chkResults As String            ' Results check informaton when checking the spreadsheet data entry
    Dim Row As Integer                  ' Row in the spreadsheet
    Row = 3                             ' starting Row
    Do While Cells(Row, ColMatnr) <> ""
    
        ' Read the input data in the spreadsheet cells, clean it up, and check it
        SSMatnr = Cells(Row, ColMatnr)
        SSMatnr = Trim(SSMatnr)
        SSBatch = Cells(Row, ColBatch)
        SSBatch = Trim(SSBatch)
        
        '
        ' Verify all the data is correctly formatted
        '
        chkResults = CheckElements(SSMatnr, SSBatch)
        
        '
        ' if chkResults is empty string then spreadsheet values are OK so we continue on to read batch info
        '
        If chkResults = "" Then
        
            '
            ' Get the SAP Material number as the one in the spreadsheet could be an 11 digit Legacy or 10 digit SAP number
            ' The function will take care of obtaining the proper SAP 10 digit number.
            '
            SAPMatnr = GetSAPMatnr(Session, SSMatnr, chkResults)
            '
            ' If we were able to determine the SAP 10 digit number it will not be an empty string, so continue on and
            ' read the batch information
            '
            If SAPMatnr <> "" Then
                '
                ' Call to the display batch tcode. Note that the last three parms are ByRef. Function will modify these
                ' Record the results along with the returned data in the corresponding rows in the spreadsheet
                '
                Cells(Row, ColResult) = msc3n_func(Session, SAPMatnr, SSBatch, DOM, SLED)
                Cells(Row, ColMfgDate) = DOM
                Cells(Row, ColSLED) = SLED
                Cells(Row, ColSAPMatnr) = SAPMatnr
            Else ' could not get SAP material number so record message in results column
                Cells(Row, ColResult) = chkResults
            End If
        Else    ' we encountered bad data in spreadsheet, so put the message in the results column.
            Cells(Row, ColResult) = chkResults
        End If
            
        ' Go to next row in the spreadsheet
        Row = Row + 1
        
    Loop
    
    Set Session = Nothing
    SAPRunCB.Value = True
Skip:
    Exit Sub
ErrHandler:
    'MsgBox ("Check SAP for active window, Unrecoverable error occured: " + Err.Description)
    
     Dim Msg As String, Ans As Variant
    Msg = "Connection to SAP has failed, Open a new SAP window and select Retry to proceed, otherwise, Select Cancel to end SAP data migration."
    Ans = MsgBox(Msg, vbRetryCancel)
    Select Case Ans
           Case vbRetry: Resume Restart:
     Case vbCancel: GoTo Quit:
      End Select
Quit:
End Sub
'----------------------------------------------------------------------------------------------------
' Invoke the MSC3N transaction to create the batch with the information from the spreadsheet
'
' PARAMETERS
'   DFBATCH_MATNR - SAP Material Number
'   DFBATCH_CHARG - Batch
'   ByRef MfgDate   - will be set to the mfg date as read from the batch master
'   ByRef SLED      - will be set to the SLED as read from batch master
' RETURNS
'   String - will be set to SAP Status or locally defined message string. Will never return "".
'
'----------------------------------------------------------------------------------------------------
Public Function msc3n_func(Session As Variant, DFBATCH_MATNR As Variant, DFBATCH_CHARG As Variant, ByRef MfgDate As Variant, ByRef SLED As Variant)
    
    Dim SAPStatusText As String  ' SAP Status text
    
    On Error GoTo ext
    '
    ' Clear out any of the data we are going to return
    '
    MfgDate = ""
    SLED = ""
    
    '
    ' Check for the key input parameters, Material, Batch, Plant - they must not be blank
    '
    If Trim(DFBATCH_MATNR) = "" Then
        Err.Description = "Material Number not defined."
        Err.Raise (-1)
    End If
    If Trim(DFBATCH_CHARG) = "" Then
        Err.Description = "Batch Number not defined."
        Err.Raise (-1)
    End If
    '
    ' Start the MSC3N transaction
    '
    Session.findById("wnd[0]").maximize
    Session.findById("wnd[0]/tbar[0]/okcd").Text = "/nMSC3N"
    Session.findById("wnd[0]").sendVKey 0
    '
    ' Set the initial data (material/batch) in the MSC3N transaction screen
    ' 20171025 - Make sure to clear the plant field as plants are not batch specific
    ' 20171101 - Make sure to clear the SLOC as batches are not SLOC specific
    '
    Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_HEADER:SAPLCHRG:1501/ctxtDFBATCH-MATNR").Text = DFBATCH_MATNR
    Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_HEADER:SAPLCHRG:1501/ctxtDFBATCH-CHARG").Text = DFBATCH_CHARG
    Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_HEADER:SAPLCHRG:1501/ctxtDFBATCH-WERKS").Text = ""              '20171025
    Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_HEADER:SAPLCHRG:1501/ctxtDFBATCH-LGORT").Text = ""              '20171101
    Session.findById("wnd[0]").sendVKey 0
    '
    ' MSC3N window is displayed, so retrieve the Mfg Date and SLED, then navigate to the Classification tab and retrieve the mfg plant batch
    ' characteristic
    '
    MfgDate = Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_TABSTRIP:SAPLCHRG:2000/tabsTS_BODY/tabpGRHD/ssubSUBSCR_BODY:SAPLCHRG:2100/ctxtMCHA-HSDAT").Text
    SLED = Session.findById("wnd[0]/usr/subSUBSCR_BATCH_MASTER:SAPLCHRG:1111/subSUBSCR_TABSTRIP:SAPLCHRG:2000/tabsTS_BODY/tabpGRHD/ssubSUBSCR_BODY:SAPLCHRG:2100/ctxtDFBATCH-MHD_IO").Text
    '
    ' Next we access the classification tab and charactersitic info. It can be the case that there is a master data issue where the material has no batch classification assigned
    ' which would result in no classification of the batch. This will cause the code below to throw an error when the class is not assigned, batch has not been classified, etc.(20171103)
    '
        
    '
    ' If we got this far all is a success so provide a status message that batch was read successfully since
    ' SAP doesn't really provide us with one.
    '
    msc3n_func = "Batch information read successfully"
    ' go back to main SAP menu
    Session.findById("wnd[0]/tbar[0]/btn[3]").press
    Exit Function
ext:
    '
    ' we obtain the SAP status message + any message from VBA.
    '
    msc3n_func = "Error: " + Session.findById("wnd[0]/sbar").Text & " VBA Err: " + Err.Description
    ' return to a main screen as in some instances we can get stuck on the msc3n screen with msc3n status msg that will not clear
    Session.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
    Session.findById("wnd[0]").sendVKey 0
End Function
'----------------------------------------------------------------------------------------------------
' Check the spreadsheet provided data. It is assumed that the parameters passed into this function
' have been trimmed of any leading or trailing spaces. This function performs basic length checking.
'
'   PARAMETERS
'       SSMatnr     - the material number from the spreadsheet
'       SSBatch     - the batch nubmer from the spreadsheet.
'   RETURNS
'       CheckElements will return "" if successful; otherwise it returns an error string
'
'
'----------------------------------------------------------------------------------------------------
Function CheckElements(SSMatnr, SSBatch) As String


    On Error GoTo CheckElementsErr
    
    ' Get some initial length values for use later
    Dim SSMatnrLen, SSBatchLen As Integer
    SSMatnrLen = Len(SSMatnr)
    SSBatchLen = Len(SSBatch)
    
    ' Check SAP material number length - must be 10 or 11 in length
    If (SSMatnrLen = 10 Or SSMatnrLen = 11) Then
        ' Check batch length > 0 and < 11 positions in length
        If (SSBatchLen > 0 And SSBatchLen < 11) Then
            CheckElements = ""  'all is ok if we get this far
        Else
            CheckElements = "Invalid batch number found in CheckElements()"
        End If
    Else
        CheckElements = "Invalid material number found in CheckElements()"
    End If
    '
    ' Return value has been set in the above logic
    ' Exit function now
    Exit Function
CheckElementsErr:
    CheckElements = "Unknown error in CheckElements()"
    Exit Function
End Function


'-------------------------------------------------------------------------------------------------------11012017
' Get the SAP Material number given a material number as entered in the spreadsheet. If an 11 digit number
' is provided in SSMatnr, the ZPPXREF transaction will be called to determine the corresponding SAP material number
' If 10 digit number is provided, this is assumed to be the same as the SAP material number and thus will simply be returned to
' the caller as is.
'
' PARAMETERS
'   Session - The connection to SAP GUI
'   SSMatnr - a material number from the spreadsheet. It is expected that this be either a 10 digit SAP number or 11 digit legacy number
'   Results - By Reference. This is provided by the caller and will be set before this function returns. If all is successful, the value set here is ""
'
' RETURNS
'   The SAP material number. If this value is "" then an error has occured. Error text is returned in the Results parameter
'
'-----------------------------------------------------------------------------------------------------------
Function GetSAPMatnr(Session As Variant, SSMatnr As String, ByRef Results As String) As String
    
    On Err GoTo GetSAPMatnrErr
    
    Dim zppxrefResult As String             ' Result of calling ZPPXREF transaction to obtain the SAP number from  11 digit number
    Dim SAPMatnr As String                  ' The SAP Material number working variable.
    Results = ""                            ' Initialize Results
    SAPMatnr = ""                           ' Initialize SAP Material Number
    
    '
    ' Check for either 11 digit or SAP 10 digit number entered in the spreadsheet
    ' When the logic below is complete the SAPMatnr variable will be an SAP 10 digit number or ""
    '
    If Len(SSMatnr) = 11 Then                    ' Legacy 11 digit number?
        '
        ' Obtain SAP Number from 11 digit Legacy Number with ZPPXREF transaction
        ' This function will set the SAPMatnr to "" if an error is encountered. The return value from this function
        ' will be the SAP error message if an SAP error occured,and we want to capture that and return it to our caller
        ' in the Results parameter
        '
        zppxrefResult = zppxref_func(Session, SSMatnr, SAPMatnr)
        Results = zppxrefResult
    ElseIf Len(SSMatnr) = 10 Then     ' We already know we have a valid SAP 10 Digit number, but check again to be sure
        ' User provided an SAP 10 digit number
        SAPMatnr = SSMatnr   ' The number from the spreadsheet is an SAP material number
        Results = ""
    Else
        ' invalid material number
        SAPMatnr = ""
        Results = "Invalid material number provided in spreadsheet"
    End If
    '
    ' Results error text has already been specified in previous logic
    ' SAPMatnr value has been set per above logic.
    ' setup the return value and exit
    '
    GetSAPMatnr = SAPMatnr
    Exit Function
GetSAPMatnrErr:
    Results = "Unknown error in GetSAPMatnr()."
    GetSAPMatnr = ""
    
     
    Exit Function
End Function




'----------------------------------------------------------------------------------------------------
' Invoke the ZPPXREF transaction to obtain the SAP ID from a Legacy ID
'
'  PARAMETERS
'    Session - the SAP GUI Session
'    TXT_ID - the Legacy 11 digit number
'    SAPMatnr - will be set to the SAP 10 digit number if found in the cross reference, otherwise
'    will be set to ""
'
'
'----------------------------------------------------------------------------------------------------
Public Function zppxref_func(Session As Variant, TXT_ID As Variant, ByRef SAPMatnr) As String
    
    Dim SAPStatusText As String  ' SAP Status text
    
     
    On Error GoTo ext
    '
    ' Clear out any of the data we are going to return
    '
    SAPMatnr = ""
    
    
    '
    ' Check for the key input parameters must not be blank
    '
    If Trim(TXT_ID) = "" Then
        Err.Description = "Material Number not defined."
        Err.Raise (-1)
    End If
    
    '
    ' Start the ZPPXREF transaction
    '
    Session.findById("wnd[0]").maximize
    Session.findById("wnd[0]/tbar[0]/okcd").Text = "/nZPPXREF"
    Session.findById("wnd[0]").sendVKey 0
    '
    ' Set the initial data - Legacy ID in the ZPPXREF transaction screen
    '
    Session.findById("wnd[0]/usr/ctxtTX_MATNR").Text = ""               ' clear out any left over data in the SAP material no. field from prior instance of transaction
    Session.findById("wnd[0]/usr/ctxtTX_ID").Text = TXT_ID        ' set the  Legacy ID field of the transaction
    Session.findById("wnd[0]/usr/ctxtTX_ID").SetFocus
    Session.findById("wnd[0]/usr/ctxtTX_ID").caretPosition = 11
    Session.findById("wnd[0]").sendVKey 0                               ' Send enter key to run the transaction
    '
    ' Pull the SAP material number from the window displayed
    '
    SAPMatnr = Session.findById("wnd[0]/usr/txtTX_MATERIAL").Text       ' Read the SAP material number field from the results window
    
    
    ' set the status message to indicate success
    zppxref_func = "Success:SAP Material Number obtained successfully"
    ' go back to main SAP menu
    Session.findById("wnd[0]/tbar[0]/btn[3]").press
    Exit Function
ext:
    '
    ' we obtain the SAP status message + any message from VBA.
    '
    zppxref_func = "Error: SAP Material Number Not Found in ZPPXREF " + Session.findById("wnd[0]/sbar").Text & " VBA Err: " + Err.Description
    ' return to a main screen as in some instances we can get stuck on the screen with a message that will not clear
    Session.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
    Session.findById("wnd[0]").sendVKey 0
    
  Unload WaitingMsg
    
End Function
 
Last edited:

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

Forum statistics

Threads
1,224,551
Messages
6,179,473
Members
452,915
Latest member
hannnahheileen

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top