Maybe something in here can be useful to someone maybe someone wants to critique.
Workbook scripts:
Main Scripts:
TodaySheet:
EmailSheet:
GUI Script (Mass Read SAP):
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 SubMain 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 SubTodaySheet:
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 SubEmailSheet:
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 SubGUI 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:
