Important Files and Macros

Promotion Macro

Promotion Macro (Save to shared path your team can access)

VBA

Sub VendorDOF()
    Dim SourceWB As Workbook, TemplateWB As Workbook, FactMasterWB As Workbook
    Dim SaveFolderPath As String, FileName As String, FullSavePath As String
    Dim OutApp As Object, OutMail As Object
    Dim TemplatePath As String, FactMasterPath As String
    Dim LastDataRow As Long, i As Long
    Dim DateDiffVal As Long, TotalDuration As Long
    Dim EmailTo As String, EmailSubject As String, EmailBody As String
    Dim BrandName As String, PromoMonth As String
    Dim SendNowResponse As VbMsgBoxResult, FactTagResponse As VbMsgBoxResult
    
    Dim StartDate As Date, EndDate As Date
    Dim CurrentStart As Date, CurrentEnd As Date
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' --- USER PROMPTS ---
    SendNowResponse = MsgBox("Will you send promotion now?", vbYesNo + vbQuestion, "Promotion Status")
    FactTagResponse = MsgBox("Do you want to generate sale tags?", vbYesNo + vbQuestion, "Fact Tags Status")
    
    ' --- OPTIMIZATION ---
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
    
    Set SourceWB = ThisWorkbook
    StartDate = SourceWB.Worksheets(1).Range("B14").Value
    EndDate = SourceWB.Worksheets(1).Range("D14").Value
    BrandName = SourceWB.Worksheets(1).Range("C26").Value
    TotalDuration = EndDate - StartDate
    
    ' --- CONFIGURATION ---
    TemplatePath = "\\nexad.nexweb.us\HQ\Code_All\Code_M\_Shared\Templates\Promotion Template.xlsx"
    FactMasterPath = "G:\Code_M\Code_MG1\CT Jason Wilmoth\Consumer Tech Fact Tags\Fact Tags V4.xlsm"

    LastDataRow = SourceWB.Worksheets(1).Range("B30:G333").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If LastDataRow < 30 Then LastDataRow = 30
    Dim rowCount As Long: rowCount = (LastDataRow - 30)

    ' --- PART 1: PREPARE MASTER DATA BLOCK ---
    Set TemplateWB = Workbooks.Open(TemplatePath)
    With TemplateWB.Worksheets(1)
        For i = 14 To (14 + rowCount)
            .Cells(i, "I").Value = "Item"
            .Cells(i, "P").Value = "Zone"
            .Cells(i, "R").Value = "3391"
            .Cells(i, "T").Value = "Fixed Price"
            .Cells(i, "Y").Value = "Both Regular and Clearance"
        Next i
        .Range("M14:M317, W14:W317, AA14:AA317, AB14:AB317").UnMerge
        SourceWB.Worksheets(1).Range("D30:D" & LastDataRow).Copy: .Range("M14").PasteSpecial xlPasteValues
        SourceWB.Worksheets(1).Range("G30:G" & LastDataRow).Copy: .Range("W14").PasteSpecial xlPasteValues
        SourceWB.Worksheets(1).Range("B30:B" & LastDataRow).Copy: .Range("AA14").PasteSpecial xlPasteValues
        SourceWB.Worksheets(1).Range("F30:F" & LastDataRow).Copy: .Range("AB14").PasteSpecial xlPasteValues
    End With

    ' --- PART 2: UPDATE FACT TAGS ONCE ---
    If FactTagResponse = vbYes Then
        On Error Resume Next
        Set FactMasterWB = Workbooks(Dir("Fact Tags V4.xlsm"))
        If FactMasterWB Is Nothing Then Set FactMasterWB = Workbooks.Open(FactMasterPath)
        On Error GoTo 0
        If Not FactMasterWB Is Nothing Then
            With FactMasterWB.Worksheets("Sale Master")
                With .Range("D2").Resize(rowCount + 1)
                    .NumberFormat = "@": .Value = SourceWB.Worksheets(1).Range("D30:D" & LastDataRow).Value
                End With
                SourceWB.Worksheets(1).Range("F30:F" & LastDataRow).Copy: .Range("L2").PasteSpecial xlPasteValues
                SourceWB.Worksheets(1).Range("G30:G" & LastDataRow).Copy: .Range("M2").PasteSpecial xlPasteValues
                .Range("H2").Resize(rowCount + 1).Value = StartDate
                .Range("I2").Resize(rowCount + 1).Value = EndDate
            End With
        End If
    End If

    ' --- PART 3: FILE GENERATION LOOP (SAVES TO DESKTOP) ---
    Set OutApp = CreateObject("Outlook.Application")
    CurrentStart = StartDate

    Do
        ' Duration Logic
        If TotalDuration > 31 Then
            CurrentEnd = DateSerial(Year(CurrentStart), Month(CurrentStart) + 1, 0)
            If CurrentEnd > EndDate Then CurrentEnd = EndDate
            PromoMonth = Format(CurrentStart, "mmmm")
        Else
            CurrentEnd = EndDate
            PromoMonth = Format(StartDate, "mmmm")
        End If
        
        PromoDates = Format(CurrentStart, "m.d.yy") & "-" & Format(CurrentEnd, "m.d.yy")
        FileName = PromoDates & " " & BrandName & " " & PromoMonth & " Promotion"
        
        ' --- DYNAMIC DESKTOP PATH LOGIC ---
        Dim DesktopPath As String
        DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
        
        If SendNowResponse = vbYes Then
            SaveFolderPath = DesktopPath & "Promotions_SendNow\" & BrandName & "\" & PromoMonth & "\"
        Else
            SaveFolderPath = DesktopPath & "Promotions_SendLater\" & PromoMonth & "\" & BrandName & "\"
        End If
        
        If Not fso.FolderExists(SaveFolderPath) Then CreateFolderRecursive fso, SaveFolderPath
        FullSavePath = SaveFolderPath & FileName & ".xlsx"

        ' Update Template Headers
        With TemplateWB.Worksheets(1)
            .Range("C4").Value = FileName
            .Range("K2").Value = SourceWB.Worksheets(1).Range("D26").Value
            .Range("G2").Value = SourceWB.Worksheets(1).Range("C27").Value
            .Range("C6").Value = CurrentStart
            .Range("E6").Value = CurrentEnd
        End With

        Application.DisplayAlerts = False
        TemplateWB.SaveCopyAs FullSavePath
        Application.DisplayAlerts = True

        ' --- EMAIL ---
        If SendNowResponse = vbYes Then
            DateDiffVal = DateDiff("d", Date, CurrentStart)
            EmailTo = IIf(DateDiffVal <= 7, "Richard.Wilmoth@NEXWEB.ORG", "SUPPORT.TECH.ACTION.RESPONSE.TEAM@nexweb.org")
            EmailSubject = IIf(DateDiffVal <= 7, "URGENT Pricing - ", "BP - ") & FileName
            
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = EmailTo: .Subject = EmailSubject
                .Body = "Hello," & vbCrLf & vbCrLf & "Attached is the promotion file for " & BrandName & " during " & PromoMonth & "."
                .Attachments.Add FullSavePath: .Display
            End With
        End If

        If TotalDuration <= 31 Then Exit Do
        CurrentStart = DateSerial(Year(CurrentStart), Month(CurrentStart) + 1, 1)
        If CurrentStart > EndDate Then Exit Do
    Loop

    TemplateWB.Close SaveChanges:=False

CleanUp:
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Process Complete. Files saved to Desktop.", vbInformation
End Sub

' Recursive Folder Helper
Sub CreateFolderRecursive(fso As Object, path As String)
    If Not fso.FolderExists(fso.GetParentFolderName(path)) Then
        CreateFolderRecursive fso, fso.GetParentFolderName(path)
    End If
    If Not fso.FolderExists(path) Then fso.CreateFolder path
End Sub

This Workbook Code (Document can't be saved over.)

VBA

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim nm As Name
    Static IsInternalSave As Boolean
    
    ' If this is the code itself triggering a save, let it through
    If IsInternalSave Then Exit Sub

    ' 1. Check for the permanent lock
    On Error Resume Next
    Set nm = ThisWorkbook.Names("PERMA_LOCK17")
    On Error GoTo 0

    ' 2. If the lock exists, block the save
    If Not nm Is Nothing Then
        MsgBox "This workbook is locked and cannot be saved again.", vbCritical
        Cancel = True
        Exit Sub
    End If

    ' 3. First time saving? Create the lock and FORCE it to stick.
    ' We turn off events so we don't trigger an infinite loop.
    Application.EnableEvents = False
    IsInternalSave = True
    
    ' Add the hidden flag
    ThisWorkbook.Names.Add Name:="PERMA_LOCK16", RefersTo:="=1", Visible:=False
    
    ' Force the workbook to save right now with the new flag
    ThisWorkbook.Save
    
    MsgBox "First save successful. This file is now permanently locked.", vbInformation
    
    IsInternalSave = False
    Application.EnableEvents = True
    
    ' Cancel the original save request because we just did it manually
    Cancel = True
End Sub

Fill in the information for all the red boxes (Start & End Dates, Brand, User ID, Buyer Number)
*Fill in or paste the information from the DOF form.
Highlighted Columns need to be filled out. Rin, Reg Sell, and Promo sell are required
*Promo Sell column MUST be fixed pricing.
*Scan back column and Model/Description in not required but nice to have for tracking purposes.
Verify Promotion fixed pricing is correct and what you want for promotion. Especially with .00 pricing endings
Click Export Button
*If Start date is within a week from today's date Email will be generated to DMM (Jason Wilmoth)
*If Start date is not within a week from today's date Email will be Generated to S.T.A.R.T Team

*Email will be generated to source based on dates with START promotion template attached.

ToSUPPORT TECH ACTION RESPONSE TEAM

Cc

SubjectBP - 3.1.26-3.1.26 MSI March Promotion

Attach📎 3.1.26-3.1.26 MSI March Promotion.xlsx 92 KB

Hello Team,

Attached is a standard promotion.

Verify Start Template information is correct before submission.
*note template will always apply "Both Regular and Clearance"

*On "Buyer Promo Tracking Document" Promotion will be logged to the Brand Tab that was entered on the macro sheet. This document will auto save upon logging the promotion

Sale Fact Tags

*Macro will auto input RINS into item column of "Sale Master" sheet of Fact tags Document and VLOOKUP the fact tags for those RINS.

*If there are #NAs on the items, then there is no fact tag for that item.

Either build fact tag for the item

or

*if fact tag is not needed for the item remove rows that have NA's

SIGN TEAM WILL NOT ACCEPT TEMPLATES WITH NA ITEMS

Once #NAs are removed click "SALE EXPORT" macro
Enter Department/Brand

Department Name ✕
Enter the Department (e.g., Electronics):
Enter Start & End Date of Promotion following MM/DD/YY format

Start Date ✕
Enter Promotion Start Date (MM/DD/YY):

End Date ✕
Enter Promotion End Date (MM/DD/YY):

*Email will be generated to sign team with fact tag template with correct file name and dates

ToPLUS-SignTeam

Cc

SubjectWeek 5 Apple Unadvertised Promotion Fact Tags 03.01.2026-03.31.2026

Attach📎 Week 5 Unadvertised Apple Promotion Fact Tag_99999_Promotion_SIGNS_HQ Distributed_20260301_20260331.xlsx 14 KB

Sign Team,

Please see attached Sale signs for Week 5 for Apple.

Thanks,

Verify information looks correct.
*START DOES NOT WANT TO BE SENT SIGNS UNTIL PROMOTION HAS BEEN KEYED/APPROVED
Save file to send tags once. promotion has been keyed by START.

Promotion Macro w/ automatic tracking and filing

Promotion Macro

Buyer Promo Tracker

Buyer Promo Tracker Template

1. Save to path team can access

*Note If RINS are the same and dates overlap at all. Column will indicate an overlapping promo has been entered

Overlap Check	Attribute 1 Page	Attribute 2 Subm.	Attribute 3 Buyer ID	DTL Start Date	DTL End Date	Item Level	Dept ID	Class ID	Subclass ID	Item ID
Overlap				1/1/26	1/30/26					1234567
Overlap				1/20/26	2/10/26					1234567

Sales Update Button

Code:

VBA

Option Explicit

' --- MAIN MACRO ---
Sub GetTotalSalesForSelectedRINs()
    Dim cn As Object, rs As Object
    Dim cell As Range, mySelection As Range
    Dim strSQL As String, itemList As String, sqlTemplate As String
    Dim startDate As String, endDate As String
    Dim dict As Object
    
    ' 1. Initial Checks
    Set mySelection = Selection
    If mySelection Is Nothing Then Exit Sub
    
    ' Get SQL Template from the named range
    On Error Resume Next
    sqlTemplate = Range("rngrmsquery").Value
    On Error GoTo 0
    
    If sqlTemplate = "" Then
        MsgBox "Could not find SQL query in 'rngrmsquery'. Please check the named range.", vbCritical
        Exit Sub
    End If

    ' 2. Prompt for Date Range
    startDate = InputBox("Enter Start Date (MM/DD/YYYY):", "Sales Start", Format(Date - 7, "mm/dd/yyyy"))
    If startDate = "" Then Exit Sub
    endDate = InputBox("Enter End Date (MM/DD/YYYY):", "Sales End", Format(Date, "mm/dd/yyyy"))
    If endDate = "" Then Exit Sub

    ' 3. Build Item List for SQL
    For Each cell In mySelection
        If Not IsEmpty(cell) Then
            itemList = itemList & "'" & Trim(cell.Value) & "',"
        End If
    Next cell
    
    If Len(itemList) > 0 Then
        itemList = Left(itemList, Len(itemList) - 1)
    Else
        MsgBox "Please select RINs first.", vbExclamation
        Exit Sub
    End If

    ' 4. Prepare Final SQL
    strSQL = Replace(sqlTemplate, "{ITEM_LIST}", itemList)
    strSQL = Replace(strSQL, "{START_DATE}", startDate)
    strSQL = Replace(strSQL, "{END_DATE}", endDate)

    ' 5. Database Connection
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    Set rs = CreateObject("ADODB.Recordset")
    rs.Open strSQL, cn

    ' 6. Map Results to Dictionary for Speed
    Set dict = CreateObject("Scripting.Dictionary")
    Do While Not rs.EOF
        dict(CStr(rs.Fields(0).Value)) = rs.Fields(1).Value
        rs.MoveNext
    Loop

    ' 7. Write Totals to Column AG
    Application.ScreenUpdating = False
    For Each cell In mySelection
        If dict.Exists(CStr(cell.Value)) Then
            ' Offset from current cell to Column AG (Column 33)
            ' This calculates the distance from the current column to AG
            Cells(cell.Row, "AG").Value = dict(CStr(cell.Value))
        Else
            Cells(cell.Row, "AG").Value = 0
        End If
    Next cell
    Application.ScreenUpdating = True

    MsgBox "Total Sales updated in Column AG.", vbInformation
    
CleanUp:
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    If Not cn Is Nothing Then cn.Close
    Exit Sub

oraerror:
    MsgBox "Oracle Error: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

' --- Password Utility (Keep this in the module) ---
Public Function zzz() As String
    Dim TextLine As String, TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum): Line Input #fNum, TextLine: Loop
    Close #fNum
    zzz = Trim(TextLine): Exit Function
CantFind:
    zzz = ""
End Function

*NOTE Sales Unit Update macro button

Highlight RIN/RINS with same start and end dates. Click button
Enter Start and end dates of promotion for those items. Start and end dates must be MM/DD/YYYY Format

Sales Start ✕

Enter Start Date (MM/DD/YYYY):

Sales End ✕

Enter End Date (MM/DD/YYYY):

Units Sold for specified period for all locations will populate into column AG. Trailing credit will auto calculate in column AH

Units Sold	Trailing Credit $$$
16	$ 80.00

Brand Tabbing

SQL Acer Amazfit Amazon Apple Asus Clinton CLX Epson Fitbit Garmin HP iBuyPower Lenovo Logitech LG Microsoft MSI Mobile Pixels Huawei Samsung Skytech SteelSeries Toshiba Turtle Beach Ultrahuman OTHER

Duplicate Brand tab for each brand and rename the tab for each brand.

*if Brand Tab Name does not match Brand name input on Promotion Macro the macro will be unable to copy information over to Promo tracker. (Text just needs to match)

Input Vendor Name Here!!!	➔		Grayr	➔		Submitted By ID
Input Buyer Number Here!!!	➔	430

Assign Tracker Path to Promotion Macro

Go to path Share Path where YOUR Tracker is located.
Right click, select Copy as path

Cut

Copy

Rename

Share

Delete

Back onto Promotion Macro Workbook.

Right click macro button
Click "assign macro"
Click "VendorDOF" and select Edit

Assign Macro ? ✕
Macro name:

CopyData
PERSONAL.XLSB!FFINSPECT
VendorDOF

Macros in:

Description
Under "Configuration" paste the path of your Buyer Promo Tracker into TrackerPath: in between the quotations.

' --- CONFIGURATION ---

TemplatePath = "\\nexad.nexweb.us\HQ\Code_All\Code_M\_Shared\Templates\Promotion Template.xlsx"

TrackerPath = ""

FactMasterPath = "G:\Code_M\Code_MG1\CT Jason Wilmoth\Consumer Tech Fact Tags\Fact Tags V4.xlsm"

Under "Part 4: File Generation Loop" and "Revised Dynamic Paths" provide a path for START templates to save to. For Now location & Later location

' --- REVISED DYNAMIC PATHS ---

If SendNowResponse = vbYes Then

' Save to: ...\2026\[Brand Name]\[Month]\

SaveFolderString = "\\nexad.nexweb.us\HQ\Code_All\Code_M\Code_MG1\Group 257\257 Promotions\Buyer Promos\2026\" & BrandName & "\" & PromoMonth & "\"

Else

' Save to: ...\2026\Send Later\[Month]\[Brand Name]\

SaveFolderString = "\\nexad.nexweb.us\HQ\Code_All\Code_M\Code_MG1\Group 257\257 Promotions\Buyer Promos\2026\Send Later\" & PromoMonth & "\" & BrandName & "\"

End If

Do Ctrl + S to save and close the window
*You must reassign macro
Right click macro button again and click assign macro.
Click VendorDOF and click OK
Save document and close.

*Now, when you run the promotion macro. The promotion information will be logged to YOUR teams Tracker file.

Fact Tags

Sale Master

Code:

VBA

Option Explicit

Sub SALEMASTER()
    Dim sourceSheet As Worksheet
    Dim targetWB As Workbook
    Dim tempWB As Workbook
    Dim lastRow As Long, i As Long
    Dim targetPath As String, tempFilePath As String
    Dim fileName As String, emailSubject As String, emailBody As String
    Dim rawStart As String, rawEnd As String, deptName As String
    Dim dateStart As Date, dateEnd As Date
    Dim fiscalYearStart As Date
    Dim weekNum As Long
    Dim OutApp As Object, OutMail As Object
    
    ' 1. Get User Inputs
    deptName = InputBox("Enter the Department (e.g., Electronics):", "Department Name")
    rawStart = InputBox("Enter Promotion Start Date (MM/DD/YY):", "Start Date")
    rawEnd = InputBox("Enter Promotion End Date (MM/DD/YY):", "End Date")
    
    If deptName = "" Or rawStart = "" Or rawEnd = "" Then Exit Sub

    ' Convert text inputs to Date variables
    On Error Resume Next
    dateStart = CDate(rawStart)
    dateEnd = CDate(rawEnd)
    On Error GoTo 0

    If dateStart = 0 Or dateEnd = 0 Then
        MsgBox "Invalid date format. Please use MM/DD/YY.", vbCritical
        Exit Sub
    End If

    ' 2. Calculate Fiscal Week based on Start Date
    fiscalYearStart = DateSerial(Year(dateStart), 2, 1)
    If dateStart < fiscalYearStart Then
        fiscalYearStart = DateSerial(Year(dateStart) - 1, 2, 1)
    End If
    weekNum = Int((dateStart - fiscalYearStart) / 7) + 1
    If weekNum > 52 Then weekNum = 52
    If weekNum < 1 Then weekNum = 1

    ' 3. Format Naming Strings
    Dim fStart As String, fEnd As String, sStart As String, sEnd As String
    fStart = Format(dateStart, "yyyymmdd"): fEnd = Format(dateEnd, "yyyymmdd")
    sStart = Format(dateStart, "mm.dd.yyyy"): sEnd = Format(dateEnd, "mm.dd.yyyy")
    
    fileName = "Week " & weekNum & " Unadvertised " & deptName & " Promotion Fact Tag_99999_Promotion_SIGNS_HQ Distributed_" & fStart & "_" & fEnd & ".xlsx"
    emailSubject = "Week " & weekNum & " " & deptName & " Unadvertised Promotion Fact Tags " & sStart & "-" & sEnd
    emailBody = "Sign Team," & vbCrLf & vbCrLf & "Please see attached Sale signs for Week " & weekNum & " for " & deptName & "." & vbCrLf & vbCrLf & "Thanks,"

    ' 4. Process Files
    Set sourceSheet = ThisWorkbook.ActiveSheet
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    targetPath = "\\nexad.nexweb.us\HQ\Code_All\Code_M\_Shared\Templates\Fact Tags\Fact Tags.xlsx"
    
    Application.ScreenUpdating = False

    On Error Resume Next
    Set targetWB = Workbooks.Open(fileName:=targetPath, ReadOnly:=True)
    On Error GoTo 0
    
    If targetWB Is Nothing Then
        MsgBox "Target file not found.", vbCritical
        Application.ScreenUpdating = True
        Exit Sub
    End If

    ' Paste everything as values into ItemImport tab
    sourceSheet.Range("A2:M" & lastRow).Copy
    targetWB.Sheets("ItemImport").Range("A2").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    ' --- NEW CLEANING LOGIC: DELETE ROWS WITH #N/A IN COLUMN C ---
    With targetWB.Sheets("ItemImport")
        Dim templateLastRow As Long
        templateLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        
        ' Loop backwards when deleting rows to avoid skipping
        For i = templateLastRow To 2 Step -1
            If IsError(.Cells(i, "C").Value) Then
                If .Cells(i, "C").Value = CVErr(xlErrNA) Then
                    .Rows(i).Delete
                End If
            End If
        Next i
    End With
    ' -------------------------------------------------------------

    ' 5. Create Temp File and Email
    targetWB.Sheets("ItemImport").Copy
    Set tempWB = ActiveWorkbook
    
    tempFilePath = Environ$("temp") & "\" & fileName
    If Dir(tempFilePath) <> "" Then Kill tempFilePath
    
    tempWB.SaveAs tempFilePath
    tempWB.Close SaveChanges:=False
    targetWB.Close SaveChanges:=False

    ' 6. Outlook Integration
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "PLUS-SignTeam@NEXWEB.ORG"
        .Subject = emailSubject
        .Body = emailBody
        .Attachments.Add tempFilePath
        .Display
    End With

    Set OutMail = Nothing: Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

SQL Tables

Ad Planner & Uploader

Ad Planner v22

Ad Bible

Ad Tracker

MSA Template

Hardlines Buyer Promo Report

Hardlines Macro

Item Lists

Inspection Tools

Open Document in Background

Paste code into "This Workbook"

Code:

VBA

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ThisWorkbook.Windows(1).Visible = False
End Sub

Supplier Inspect 1

Supplier Information Macro.v1

Code:

VBA

Option Explicit

' --- MAIN MACRO: Populate Item, Parent, Dept, SOH, Supplier ID & Name ---
Sub SupplierInspect()
    Dim cn As Object ' ADODB.Connection
    Dim rs As Object ' ADODB.Recordset
    Dim cell As Range
    Dim strSQL As String
    
    ' 1. Capture multiple items from selection
    If Selection.Columns.Count > 1 Then
        MsgBox "Please select only one column of data.", vbExclamation, "Selection Error"
        Exit Sub
    End If
    
    ' 2. Establish Connection to RMS10
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    
    ' Uses the zzz function to fetch the password from the network
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Initialize and Clear the Form
    With frmRINInspection
        .txtTransRIN.Value = ""
        .txtParentRIN.Value = ""
        .txtDept.Value = ""
        .txtSOH.Value = "" ' New distinct box for Stock on Hand
        .txtSupplierID.Value = ""
        .txtSupplierName.Value = ""
        .Caption = "Item & Supplier Inspection"
    End With

    ' 4. Loop through each selected cell to batch data
    For Each cell In Selection
        If Not IsEmpty(cell) Then
            ' SQL: Joins ITEM_SUPP_COUNTRY (a), SUPS (s), ITEM_MASTER (m), and ITEM_LOC_SOH (oh)
            ' Uses SUM on STOCK_ON_HAND to get total inventory across all locations
            strSQL = "SELECT a.ITEM, m.ITEM_PARENT, m.DEPT, a.SUPPLIER, s.SUP_NAME, " & _
                     "(SELECT SUM(oh.STOCK_ON_HAND) FROM ITEM_LOC_SOH oh WHERE oh.ITEM = a.ITEM) as TOTAL_SOH " & _
                     "FROM ITEM_SUPP_COUNTRY a " & _
                     "INNER JOIN SUPS s ON a.SUPPLIER = s.SUPPLIER " & _
                     "INNER JOIN ITEM_MASTER m ON a.ITEM = m.ITEM " & _
                     "WHERE a.PRIMARY_SUPP_IND = 'Y' AND a.ITEM = '" & Trim(cell.Value) & "'"
            
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open strSQL, cn
            
            If Not rs.EOF Then
                ' Appends results with vbCrLf to maintain vertical list alignment
                With frmRINInspection
                    .txtTransRIN.Value = .txtTransRIN.Value & rs("ITEM") & vbCrLf
                    .txtParentRIN.Value = .txtParentRIN.Value & rs("ITEM_PARENT") & vbCrLf
                    .txtDept.Value = .txtDept.Value & rs("DEPT") & vbCrLf
                    ' Format SOH to 0 if null
                    .txtSOH.Value = .txtSOH.Value & IIf(IsNull(rs("TOTAL_SOH")), "0", rs("TOTAL_SOH")) & vbCrLf
                    .txtSupplierID.Value = .txtSupplierID.Value & rs("SUPPLIER") & vbCrLf
                    .txtSupplierName.Value = .txtSupplierName.Value & rs("SUP_NAME") & vbCrLf
                End With
            End If
            rs.Close
        End If
    Next cell

    ' 5. Show the Form
    ' Ensure MultiLine property is TRUE for all result textboxes in the VBA Properties window
    frmRINInspection.Show 0

CleanUp:
    On Error Resume Next
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not cn Is Nothing Then If cn.State = 1 Then cn.Close
    Set rs = Nothing
    Set cn = Nothing
    Exit Sub

oraerror:
    MsgBox "Oracle Connection Error: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

' --- PASSWORD FUNCTION: Retrieve from Network ---
Public Function zzz() As String
    Dim TextLine As String
    Dim TargetFile As String

    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum)
        Line Input #fNum, TextLine
    Loop
    Close #fNum

    zzz = Trim(TextLine)
    Exit Function

CantFind:
    MsgBox "Problem connecting to network drive. Check your VPN/Access.", vbInformation, "Connection Error"
    zzz = ""
End Function

Trans Rin:	Parent Rin:	Supplier ID:	Supplier Name:	Dept:	SOH:
14758414	14758397	66272964	SONY ELECTRONICS INC.	811	13

Supplier Inspect 2

Supplier Information Macro.v2

Code:

VBA

Option Explicit

' --- MAIN MACRO: Populate Item, Parent, Dept, SOH, Cost, Retail, Desc, Supplier ID & Name ---
Sub SupplierINSPECTORv2()
    Dim cn As Object ' ADODB.Connection
    Dim rs As Object ' ADODB.Recordset
    Dim cell As Range
    Dim strSQL As String
    
    ' 1. Capture multiple items from selection
    If Selection.Columns.Count > 1 Then
        MsgBox "Please select only one column of data.", vbExclamation, "Selection Error"
        Exit Sub
    End If
    
    ' 2. Establish Connection to RMS10
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    
    ' Uses the zzz function to fetch the password from the network
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Initialize and Clear the Form
    With frmRINInspection
        .txtTransRIN.Value = ""
        .txtParentRIN.Value = ""
        .txtDept.Value = ""
        .txtSOH.Value = ""
        .txtUnitCost.Value = ""
        .txtRetail.Value = "" ' New box for Unit Retail
        .txtDescription.Value = ""
        .txtSupplierID.Value = ""
        .txtSupplierName.Value = ""
        .Caption = "Item & Supplier Inspection"
    End With

    ' 4. Loop through each selected cell to batch data
    For Each cell In Selection
        If Not IsEmpty(cell) Then
            ' SQL: Includes AVG UNIT_COST and AVG UNIT_RETAIL
            ' The WHERE clause handles both Parent and Transaction level highlights
            strSQL = "SELECT a.ITEM, m.ITEM_PARENT, m.DEPT, m.ITEM_DESC, a.SUPPLIER, s.SUP_NAME, " & _
                     "(SELECT SUM(oh.STOCK_ON_HAND) FROM ITEM_LOC_SOH oh WHERE oh.ITEM = a.ITEM) as TOTAL_SOH, " & _
                     "(SELECT AVG(oh.UNIT_COST) FROM ITEM_LOC_SOH oh WHERE oh.ITEM = a.ITEM) as AVG_COST, " & _
                     "(SELECT AVG(il.UNIT_RETAIL) FROM ITEM_LOC il WHERE il.ITEM = a.ITEM) as AVG_RETAIL " & _
                     "FROM ITEM_SUPP_COUNTRY a " & _
                     "INNER JOIN SUPS s ON a.SUPPLIER = s.SUPPLIER " & _
                     "INNER JOIN ITEM_MASTER m ON a.ITEM = m.ITEM " & _
                     "WHERE a.PRIMARY_SUPP_IND = 'Y' " & _
                     "AND (m.ITEM = '" & Trim(cell.Value) & "' OR m.ITEM_PARENT = '" & Trim(cell.Value) & "')"
            
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open strSQL, cn
            
            ' Loop through results to handle all children if a Parent was highlighted
            Do While Not rs.EOF
                With frmRINInspection
                    .txtTransRIN.Value = .txtTransRIN.Value & rs("ITEM") & vbCrLf
                    .txtParentRIN.Value = .txtParentRIN.Value & rs("ITEM_PARENT") & vbCrLf
                    .txtDept.Value = .txtDept.Value & rs("DEPT") & vbCrLf
                    .txtSOH.Value = .txtSOH.Value & IIf(IsNull(rs("TOTAL_SOH")), "0", rs("TOTAL_SOH")) & vbCrLf
                    
                    ' Formatting Currency values to 2 decimal places
                    .txtUnitCost.Value = .txtUnitCost.Value & Format(IIf(IsNull(rs("AVG_COST")), 0, rs("AVG_COST")), "0.00") & vbCrLf
                    .txtRetail.Value = .txtRetail.Value & Format(IIf(IsNull(rs("AVG_RETAIL")), 0, rs("AVG_RETAIL")), "0.00") & vbCrLf
                    
                    .txtDescription.Value = .txtDescription.Value & rs("ITEM_DESC") & vbCrLf
                    .txtSupplierID.Value = .txtSupplierID.Value & rs("SUPPLIER") & vbCrLf
                    .txtSupplierName.Value = .txtSupplierName.Value & rs("SUP_NAME") & vbCrLf
                End With
                rs.MoveNext
            Loop
            rs.Close
        End If
    Next cell

    ' 5. Show the Form
    frmRINInspection.Show 0

CleanUp:
    On Error Resume Next
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not cn Is Nothing Then If cn.State = 1 Then cn.Close
    Set rs = Nothing
    Set cn = Nothing
    Exit Sub

oraerror:
    MsgBox "Oracle Connection Error: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

' --- PASSWORD FUNCTION: Retrieve from Network ---
Public Function zzz() As String
    Dim TextLine As String
    Dim TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum)
        Line Input #fNum, TextLine
    Loop
    Close #fNum
    zzz = Trim(TextLine)
    Exit Function
CantFind:
    MsgBox "Problem connecting to network drive. Check your VPN/Access.", vbInformation, "Connection Error"
    zzz = ""
End Function

Trans Rin:	Parent Rin:	Description:	Cost:	Retail:	Supplier ID:	Supplier Name:	Dept:	SOH:
14758414	14758397	Sony XR77A80L 77-Inch 4K HDR OLED TV_D	2347.99	3449.99	66272964	SONY ELECTRONICS INC.	811	13

FFINSPECT 1

Frustrated Freight Macro.v1

Code:

VBA

Option Explicit

' --- MAIN MACRO ---
Sub FFINS1()
    Dim cn As Object, rs As Object
    Dim cell As Range, mySelection As Range
    Dim strSQL As String, selectedLocs As String
    
    Set mySelection = Selection
    If mySelection Is Nothing Then Exit Sub
    
    ' 1. Trigger the Choice Form
    frmChoice.Tag = ""
    frmChoice.Show ' Macro pauses here until frmChoice is hidden
    
    selectedLocs = frmChoice.Tag
    If selectedLocs = "" Then Exit Sub ' Exit if user closed form without selection
    Unload frmChoice

    ' 2. Database Connection
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Reset Inspection Form Textboxes
    With frmRINInspection
        .txtTransRIN.Value = ""     ' Box 1
        .txtParentRIN.Value = ""    ' Box 2
        .txtDescription.Value = ""  ' Box 3
        .txtDept.Value = ""         ' Box 4
        .txtSupplierID.Value = ""   ' Box 5 (Primary Supplier)
        .txtSupplierName.Value = "" ' Box 6 (Vendor)
        .txtLoc.Value = ""          ' Box 7 (Location)
        .txtLastSold.Value = ""     ' Box 8
        .txtSOH.Value = ""          ' Box 9 (Store OH)
        .txtOHTotal.Value = ""      ' Box 10
        .txtMin.Value = ""          ' Box 11
        .txtMax.Value = ""          ' Box 12
        .txtLastRec.Value = ""      ' Box 13 (NEW: Last Received)
    End With

    ' 4. Main Data Loop
    For Each cell In mySelection
        If Not IsEmpty(cell) Then
            strSQL = GetDetailedFormSQL("'" & Trim(cell.Value) & "'", selectedLocs)
            
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open strSQL, cn
            
            Do While Not rs.EOF
                With frmRINInspection
                    .txtTransRIN.Value = .txtTransRIN.Value & rs("ITEM_TRANS") & vbCrLf
                    .txtParentRIN.Value = .txtParentRIN.Value & rs("ITEM_PARENT") & vbCrLf
                    .txtDescription.Value = .txtDescription.Value & rs("DESCRIPTION") & vbCrLf
                    .txtDept.Value = .txtDept.Value & rs("DEPT") & vbCrLf
                    .txtSupplierID.Value = .txtSupplierID.Value & rs("PRIMARY_SUPPLIER") & vbCrLf
                    .txtSupplierName.Value = .txtSupplierName.Value & rs("VENDOR") & vbCrLf
                    .txtLoc.Value = .txtLoc.Value & rs("LOCATION") & " - " & rs("LOC_NAME") & vbCrLf
                    .txtLastSold.Value = .txtLastSold.Value & rs("LAST_SOLD") & vbCrLf
                    .txtSOH.Value = .txtSOH.Value & rs("STORE_OH") & vbCrLf
                    .txtOHTotal.Value = .txtOHTotal.Value & rs("OH_TOTAL") & vbCrLf
                    .txtMin.Value = .txtMin.Value & rs("MIN_QTY") & vbCrLf
                    .txtMax.Value = .txtMax.Value & rs("MAX_QTY") & vbCrLf
                    .txtLastRec.Value = .txtLastRec.Value & rs("LAST_REC") & vbCrLf
                End With
                rs.MoveNext
            Loop
            rs.Close
        End If
    Next cell

    ' 5. Display the Final Results
    frmRINInspection.Show 0
    Exit Sub

oraerror:
    MsgBox "Oracle Error: " & Err.Description, vbCritical
    If Not cn Is Nothing Then cn.Close
End Sub

' --- SQL BUILDER ---
Private Function GetDetailedFormSQL(itemVal As String, locs As String) As String
    Dim s As String
    s = "SELECT il.loc ""LOCATION"", (SELECT Store_Name FROM Store WHERE Store=il.loc) ""LOC_NAME"", "
    s = s & "im.item ""ITEM_TRANS"", im.item_parent ""ITEM_PARENT"", im.item_desc ""DESCRIPTION"", im.dept ""DEPT"", "
    s = s & "isu.supplier ""PRIMARY_SUPPLIER"", (SELECT sup2.sup_name FROM sups sup2 WHERE sup2.supplier=il.primary_supp) ""VENDOR"", "
    s = s & "TO_CHAR(ils.last_sold, 'mm/dd/yyyy') ""LAST_SOLD"", "
    s = s & "TO_CHAR(ils.last_received, 'mm/dd/yyyy') ""LAST_REC"", " ' Added Field
    s = s & "decode(ils.loc_type,'S', ils.stock_on_hand,0) ""STORE_OH"", "
    s = s & "(decode(ils.loc_type,'S', ils.stock_on_hand,0)+decode(ils.loc_type,'W', ils.stock_on_hand,0)+ils.in_transit_qty) AS ""OH_TOTAL"", "
    s = s & "nvl(ril.min_stock,0) ""MIN_QTY"", nvl(ril.max_stock,0) ""MAX_QTY"" "
    s = s & "FROM (SELECT * from item_master WHERE (item IN (" & itemVal & ") OR item_parent IN (" & itemVal & ")) AND tran_level = item_level) im "
    s = s & "LEFT JOIN rms.item_loc il ON im.item=il.item "
    s = s & "LEFT JOIN rms.item_supplier isu ON im.item=isu.item AND il.item=isu.item "
    s = s & "LEFT JOIN rms.item_loc_soh ils ON im.item=ils.item AND il.loc=ils.loc "
    s = s & "LEFT JOIN rms.repl_item_loc ril ON im.item=ril.item AND il.loc=ril.location "
    s = s & "WHERE im.item_number_type='ITEM' AND isu.primary_supp_ind = 'Y' "
    s = s & "AND il.loc IN (" & locs & ") "
    s = s & "ORDER BY il.loc ASC"
    GetDetailedFormSQL = s
End Function

' --- PASSWORD HANDLER ---
Public Function zzz() As String
    Dim TextLine As String, TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum): Line Input #fNum, TextLine: Loop
    Close #fNum
    zzz = Trim(TextLine): Exit Function
CantFind:
    zzz = ""
End Function

Trans Rin:	Parent Rin:	Description:	Dept:	Supplier ID:	Supplier Name:	Location:	Last Sold Date:	Last Received:	SOH:	OH (Total):	Min:	Max:
14758414	14758397	Sony XR77A80L 77-Inch 4K HDR OLED TV_D	811	66272964	SONY ELECTRONICS INC.	10 - NORF MAIN STORE	09/02/2024	07/24/2024	0	0	0	0

FFInspect

Frustrated Freight Macro.v2

Code:

VBA

Option Explicit

' --- MAIN MACRO ---
Sub FFINS1()
    Dim cn As Object, rs As Object
    Dim cell As Range, mySelection As Range
    Dim strSQL As String, selectedLocs As String
    
    Set mySelection = Selection
    If mySelection Is Nothing Then Exit Sub
    
    ' 1. Trigger the Choice Form
    frmChoice.Tag = ""
    frmChoice.Show ' Macro pauses here until frmChoice is hidden
    
    selectedLocs = frmChoice.Tag
    If selectedLocs = "" Then Exit Sub ' Exit if user closed form without selection
    Unload frmChoice

    ' 2. Database Connection
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Reset Inspection Form Textboxes
    With frmRINInspection
        .txtTransRIN.Value = ""     ' Box 1
        .txtParentRIN.Value = ""    ' Box 2
        .txtDescription.Value = ""  ' Box 3
        .txtDept.Value = ""         ' Box 4
        .txtSupplierID.Value = ""   ' Box 5 (Primary Supplier)
        .txtSupplierName.Value = "" ' Box 6 (Vendor)
        .txtLoc.Value = ""          ' Box 7 (Location)
        .txtLastSold.Value = ""     ' Box 8
        .txtSOH.Value = ""          ' Box 9 (Store OH)
        .txtOHTotal.Value = ""      ' Box 10
        .txtMin.Value = ""          ' Box 11
        .txtMax.Value = ""          ' Box 12
        .txtLastRec.Value = ""      ' Box 13 (NEW: Last Received)
    End With

    ' 4. Main Data Loop
    For Each cell In mySelection
        If Not IsEmpty(cell) Then
            strSQL = GetDetailedFormSQL("'" & Trim(cell.Value) & "'", selectedLocs)
            
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open strSQL, cn
            
            Do While Not rs.EOF
                With frmRINInspection
                    .txtTransRIN.Value = .txtTransRIN.Value & rs("ITEM_TRANS") & vbCrLf
                    .txtParentRIN.Value = .txtParentRIN.Value & rs("ITEM_PARENT") & vbCrLf
                    .txtDescription.Value = .txtDescription.Value & rs("DESCRIPTION") & vbCrLf
                    .txtDept.Value = .txtDept.Value & rs("DEPT") & vbCrLf
                    .txtSupplierID.Value = .txtSupplierID.Value & rs("PRIMARY_SUPPLIER") & vbCrLf
                    .txtSupplierName.Value = .txtSupplierName.Value & rs("VENDOR") & vbCrLf
                    .txtLoc.Value = .txtLoc.Value & rs("LOCATION") & " - " & rs("LOC_NAME") & vbCrLf
                    .txtLastSold.Value = .txtLastSold.Value & rs("LAST_SOLD") & vbCrLf
                    .txtSOH.Value = .txtSOH.Value & rs("STORE_OH") & vbCrLf
                    .txtOHTotal.Value = .txtOHTotal.Value & rs("OH_TOTAL") & vbCrLf
                    .txtMin.Value = .txtMin.Value & rs("MIN_QTY") & vbCrLf
                    .txtMax.Value = .txtMax.Value & rs("MAX_QTY") & vbCrLf
                    .txtLastRec.Value = .txtLastRec.Value & rs("LAST_REC") & vbCrLf
                End With
                rs.MoveNext
            Loop
            rs.Close
        End If
    Next cell

    ' 5. Display the Final Results
    frmRINInspection.Show 0
    Exit Sub

oraerror:
    MsgBox "Oracle Error: " & Err.Description, vbCritical
    If Not cn Is Nothing Then cn.Close
End Sub

' --- SQL BUILDER ---
Private Function GetDetailedFormSQL(itemVal As String, locs As String) As String
    Dim s As String
    s = "SELECT il.loc ""LOCATION"", (SELECT Store_Name FROM Store WHERE Store=il.loc) ""LOC_NAME"", "
    s = s & "im.item ""ITEM_TRANS"", im.item_parent ""ITEM_PARENT"", im.item_desc ""DESCRIPTION"", im.dept ""DEPT"", "
    s = s & "isu.supplier ""PRIMARY_SUPPLIER"", (SELECT sup2.sup_name FROM sups sup2 WHERE sup2.supplier=il.primary_supp) ""VENDOR"", "
    s = s & "TO_CHAR(ils.last_sold, 'mm/dd/yyyy') ""LAST_SOLD"", "
    s = s & "TO_CHAR(ils.last_received, 'mm/dd/yyyy') ""LAST_REC"", " ' Added Field
    s = s & "decode(ils.loc_type,'S', ils.stock_on_hand,0) ""STORE_OH"", "
    s = s & "(decode(ils.loc_type,'S', ils.stock_on_hand,0)+decode(ils.loc_type,'W', ils.stock_on_hand,0)+ils.in_transit_qty) AS ""OH_TOTAL"", "
    s = s & "nvl(ril.min_stock,0) ""MIN_QTY"", nvl(ril.max_stock,0) ""MAX_QTY"" "
    s = s & "FROM (SELECT * from item_master WHERE (item IN (" & itemVal & ") OR item_parent IN (" & itemVal & ")) AND tran_level = item_level) im "
    s = s & "LEFT JOIN rms.item_loc il ON im.item=il.item "
    s = s & "LEFT JOIN rms.item_supplier isu ON im.item=isu.item AND il.item=isu.item "
    s = s & "LEFT JOIN rms.item_loc_soh ils ON im.item=ils.item AND il.loc=ils.loc "
    s = s & "LEFT JOIN rms.repl_item_loc ril ON im.item=ril.item AND il.loc=ril.location "
    s = s & "WHERE im.item_number_type='ITEM' AND isu.primary_supp_ind = 'Y' "
    s = s & "AND il.loc IN (" & locs & ") "
    s = s & "ORDER BY il.loc ASC"
    GetDetailedFormSQL = s
End Function

' --- PASSWORD HANDLER ---
Public Function zzz() As String
    Dim TextLine As String, TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum): Line Input #fNum, TextLine: Loop
    Close #fNum
    zzz = Trim(TextLine): Exit Function
CantFind:
    zzz = ""
End Function

RIN Inspector ✕

Main

Which Warehouse?

9830 9930 9840 9950

Sales Start ✕

Enter Start Date for Sales (MM/DD/YYYY):

Sales End ✕

Enter End Date for Sales (MM/DD/YYYY):

CLASS Inspector

CLASS Macro

Code:

VBA

Option Explicit

Sub CLASS()
    Dim cn As Object, rs As Object
    Dim cell As Range, mySelection As Range
    Dim strSQL As String, itemList As String
    
    ' 1. Selection Handling
    Set mySelection = Selection
    If mySelection.Columns.Count > 1 Then
        MsgBox "Please select only one column of data.", vbExclamation, "Selection Error"
        Exit Sub
    End If
    
    ' Build batch list
    For Each cell In mySelection
        If Not IsEmpty(cell) Then
            itemList = itemList & "'" & Trim(cell.Value) & "',"
        End If
    Next cell
    
    If Len(itemList) > 0 Then
        itemList = Left(itemList, Len(itemList) - 1)
    Else
        Exit Sub
    End If

    ' 2. Establish Connection
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    cn.CursorLocation = 3
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Clear Form Boxes
    ' Ensure these 5 boxes exist on frmRINInspection
    With frmRINInspection
        .txtTrans.Value = ""
        .txtParent.Value = ""
        .txtDept.Value = ""
        .txtClass.Value = ""
        .txtSubclass.Value = ""
    End With

    ' 4. SQL: Joining Class and Subclass tables for names
    strSQL = "SELECT DISTINCT " & _
             "  m.ITEM, " & _
             "  m.ITEM_PARENT, " & _
             "  m.DEPT, " & _
             "  m.CLASS || ' - ' || c.CLASS_NAME as CLASS_STR, " & _
             "  m.SUBCLASS || ' - ' || s.SUB_NAME as SUBCLASS_STR " & _
             "FROM ITEM_MASTER m " & _
             "INNER JOIN CLASS c ON m.DEPT = c.DEPT AND m.CLASS = c.CLASS " & _
             "INNER JOIN SUBCLASS s ON m.DEPT = s.DEPT AND m.CLASS = s.CLASS AND m.SUBCLASS = s.SUBCLASS " & _
             "WHERE (m.ITEM IN (" & itemList & ") OR m.ITEM_PARENT IN (" & itemList & ")) " & _
             "AND m.ITEM_NUMBER_TYPE = 'ITEM' " & _
             "ORDER BY m.DEPT, m.ITEM"

    Set rs = CreateObject("ADODB.Recordset")
    rs.Open strSQL, cn
    
    ' 5. Populate Form
    If Not rs.EOF Then
        Do While Not rs.EOF
            With frmRINInspection
                .txtTrans.Value = .txtTrans.Value & nvl(rs("ITEM"), "") & vbCrLf
                .txtParent.Value = .txtParent.Value & nvl(rs("ITEM_PARENT"), "") & vbCrLf
                .txtDept.Value = .txtDept.Value & nvl(rs("DEPT"), "") & vbCrLf
                .txtClass.Value = .txtClass.Value & nvl(rs("CLASS_STR"), "") & vbCrLf
                .txtSubclass.Value = .txtSubclass.Value & nvl(rs("SUBCLASS_STR"), "") & vbCrLf
            End With
            rs.MoveNext
        Loop
        frmRINInspection.Show 0
    Else
        MsgBox "No hierarchy data found.", vbInformation
    End If

    GoTo CleanUp

oraerror:
    MsgBox "Oracle Error: " & Err.Description, vbCritical
CleanUp:
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    If Not cn Is Nothing Then cn.Close
    Set rs = Nothing: Set cn = Nothing
End Sub

' Helper to handle Nulls
Private Function nvl(val As Variant, replaceWith As String) As String
    If IsNull(val) Or IsEmpty(val) Then nvl = replaceWith Else nvl = CStr(val)
End Function

' Password retrieval
Public Function zzz() As String
    Dim TextLine As String, TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum): Line Input #fNum, TextLine: Loop
    Close #fNum
    zzz = Trim(TextLine): Exit Function
CantFind:
    zzz = ""
End Function

Trans Rin:	Parent Rin:	Description:	Class:	Subclass:
13544915	13544902		1001 – HOUSEHOLD BAT	1 – ALKALINE

VPNrinfinder

VPN Rin Finder Macro

Code:

VBA

Option Explicit

' --- MAIN MACRO ---
Sub VPNRINFIND()
    Dim cn As Object, rs As Object
    Dim cell As Range, mySelection As Range
    Dim strSQL As String, inputVal As String
    
    ' 1. Selection Handling
    Set mySelection = Selection
    If mySelection.Columns.Count > 1 Then
        MsgBox "Your selection must be restricted to one column of data.", vbExclamation, "Bad Selection"
        Exit Sub
    End If

    ' 2. Establish Connection
    On Error GoTo oraerror
    Set cn = CreateObject("ADODB.Connection")
    cn.CursorLocation = 3
    cn.Open "Driver={Microsoft ODBC for Oracle};Server=RMS1P.NEXWEB.US;Uid=View_only;Pwd=" & zzz() & ";"

    ' 3. Clear Form
    With frmRINInspection
        .txtTransRIN.Value = ""
        .txtParentRIN.Value = ""
        .txtUPC.Value = ""
        .txtVPN.Value = ""
    With

    ' 4. Data Loop
    For Each cell In mySelection
        If Not IsEmpty(cell) Then
            inputVal = Trim(cell.Value)
            
            ' REFINED SQL:
            ' Added m.ITEM <> m.ITEM_PARENT check to avoid duplicate entries in Trans box
            ' Added a specialized subquery to grab the Primary UPC specifically
            strSQL = "SELECT DISTINCT m.ITEM ""Item (RIN) Trans"", m.ITEM_PARENT ""Item (RIN) Parent"", v.VPN, " & _
                     "(SELECT MAX(u.ITEM) FROM ITEM_MASTER u WHERE u.ITEM_PARENT = m.ITEM_PARENT " & _
                     " AND u.ITEM_NUMBER_TYPE IN ('UCC14','UPC-A','EAN13') AND u.PRIMARY_REF_ITEM_IND = 'Y') as ""Primary UPC"" " & _
                     "FROM ITEM_MASTER m " & _
                     "LEFT JOIN ITEM_SUPPLIER v ON m.ITEM = v.ITEM " & _
                     "WHERE m.ITEM_NUMBER_TYPE = 'ITEM' " & _
                     "AND m.ITEM <> m.ITEM_PARENT " & _
                     "AND (" & _
                     "   m.ITEM = '" & inputVal & "' " & _
                     "   OR m.ITEM_PARENT = '" & inputVal & "' " & _
                     "   OR v.VPN = '" & inputVal & "' " & _
                     "   OR m.ITEM IN (SELECT i3.ITEM_PARENT FROM ITEM_MASTER i3 WHERE i3.ITEM = '" & inputVal & "' AND i3.ITEM_NUMBER_TYPE <> 'ITEM')" & _
                     ") " & _
                     "ORDER BY m.ITEM"

            ' IF NO RECORDS FOUND WITH FILTER (Handling "One-Off" items where Parent = Item)
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open strSQL, cn
            
            ' If the specific filter returned nothing, run a broader search for that specific item
            If rs.EOF Then
                rs.Close
                strSQL = Replace(strSQL, "AND m.ITEM <> m.ITEM_PARENT", "")
                rs.Open strSQL, cn
            End If

            Do While Not rs.EOF
                With frmRINInspection
                    .txtTransRIN.Value = .txtTransRIN.Value & nvl(rs("Item (RIN) Trans"), "") & vbCrLf
                    .txtParentRIN.Value = .txtParentRIN.Value & nvl(rs("Item (RIN) Parent"), "") & vbCrLf
                    .txtUPC.Value = .txtUPC.Value & nvl(rs("Primary UPC"), "") & vbCrLf
                    .txtVPN.Value = .txtVPN.Value & nvl(rs("VPN"), "") & vbCrLf
                End With
                rs.MoveNext
            Loop
            rs.Close
        End If
    Next cell

    frmRINInspection.Show 0
    Exit Sub

oraerror:
    MsgBox "Oracle Error: " & Err.Description, vbCritical
    If Not cn Is Nothing Then cn.Close
End Sub

' Helper to handle Nulls
Private Function nvl(val As Variant, replaceWith As String) As String
    If IsNull(val) Or IsEmpty(val) Then nvl = replaceWith Else nvl = CStr(val)
End Function

' Password retrieval
Public Function zzz() As String
    Dim TextLine As String, TargetFile As String
    TargetFile = "\\nexad.nexweb.us\HQ\Common\JackF\mi4ma3\ToadPW\ToadPW.txt"
    On Error GoTo CantFind
    Dim fNum As Integer: fNum = FreeFile
    Open TargetFile For Input As #fNum
    Do While Not EOF(fNum): Line Input #fNum, TextLine: Loop
    Close #fNum
    zzz = Trim(TextLine): Exit Function
CantFind:
    zzz = ""
End Function

Trans Rin:	Parent Rin:	UPC:	VPN:
17483392	17483382		GS108-400NAS