# Utilization on MS hold Analysis generated on: 4/1/2025 4:00:27 PM --- ## Record Source - *None* ## Controls | Control Name | Reference | |--------------|-----------| | List86 (Row Source) | | | Combo12 (Row Source) | [[Tables/[Metals];]] | | TypeofMetal (Row Source) | [[Tables/[MetalPrices]] | | GaugeOfType (Row Source) | [[Tables/MetalPrices]] | | List158 (Row Source) | | | Combo165 (Row Source) | [[Tables/[Base]] | ## VBA Code ```vba Option Compare Database Dim fromar(10), toar(10), curar(10), CurrSetSize(10), CurrSetGw(10), CurrSetAw(10), Sheets Dim BestSS(10, 3, 6) ' | ' +---------------------> 0 - Sheet Size ' 1 - Price for sheet ' 2 - Pounds used Gw ' 3 - Aw ' Private Sub BegLength_LostFocus() Call CalcIters End Sub Private Sub BegWidth_LostFocus() Call CalcIters End Sub Private Sub CalcIters() sz1 = Abs(EndWidth - BegWidth) If IncWidth <> 0 Then sz1 = sz1 / Abs(IncWidth) End If sz1 = sz1 + 1 sz2 = Abs(EndLength - BegLength) If IncLength <> 0 Then sz2 = sz2 / Abs(IncLength) End If sz2 = sz2 + 1 sz1 = sz1 * sz2 Iterations = Format$(sz1, "0") End Sub Private Sub cmdButtnCalc_Click() Dim MainDB As Database, MainSet As Recordset Dim MainDB2 As Database, MainSet2 As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainDB2 = DBEngine.Workspaces(0).Databases(0) lblstatus.Caption = "Selecting Parts for Material Utilization" DoCmd.RunMacro "Material Selections for Utilitzation" lblstatus.Caption = "Selection Complete" Refresh lblstatus.Caption = "Moving Parts to AS400" Set MainSet = MainDB.OpenRecordset("RMSFILES#_IEMUP1A0") ' Create dynaset. Set MainSet2 = MainDB2.OpenRecordset("Util Selection 2") ' Create dynaset. lblstatus.Caption = "Purging AS400 product number file" MainSet.MoveFirst Do If Not (MainSet.EOF) Then MainSet.Delete DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop lblstatus.Caption = "Purging AS400 result file" MainSet2.MoveFirst Do If Not (MainSet2.EOF) Then p$ = MainSet2!prt MainSet.AddNew MainSet!PRDNO = p$ MainSet.Update DoEvents Else DoEvents Exit Do End If MainSet2.MoveNext Loop lblstatus.Caption = "Activating AS400 Program" DoEvents ActiveXCtl24.DoClick lblstatus.Caption = "Retrieving Results" UtilResult1.SourceObject = "tricks" DoCmd.RunMacro "AS400 Utiliz Results" UtilResult1.SourceObject = "Util Result1" ' lblStatus.Caption = "Calculating material utilization on parts" lblstatus.Caption = "Done" End Sub Private Sub Command25_Click() Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util Matrix") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Exit Sub End If First = True For Sheet_Width! = BGW! To EDW! Step ICW! For Sheet_Length! = BGL! To EDL! Step ICL! SheetWidth = Sheet_Width! SheetLength = Sheet_Length! GoSub DoSheetSize Main2Set.AddNew Main2Set!Gw = TotalGw! Main2Set!SheetL = SheetLength Main2Set!sheetw = SheetWidth Main2Set.Update If (First) Or (LGrossWt > TotalGw!) Then LGrossWt = TotalGw! LSheetL = SheetLength LSheetW = SheetWidth First = False End If Next Next Cost = 0 Exit Sub DoSheetSize: lblstatus.Caption = "Calculate Gross Weight for all parts at this sheet" TotalGw! = 0 MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> 1 Then Sheet_Width! = SheetWidth Sheet_Length! = SheetLength Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) TotalGw! = Gw! + TotalGw! End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Return End Sub Private Sub Command43_Click() On Error GoTo Err_Command43_Click Call Form.Command120_Click ' DoCmd.GoToRecord acDataForm, "UtilResult1", acNext Exit_Command43_Click: Exit Sub Err_Command43_Click: MsgBox Err.Description Resume Exit_Command43_Click End Sub Private Sub Command55_Click() lblstatus.Caption = "Running Query to pick parts for Material Utilization" DoCmd.RunMacro "Filter across Materials Utilitzation" lblstatus.Caption = "Selection Complete" Refresh End Sub Private Sub BestSheets_Click() Call GetTheBestAnswers End Sub Private Sub cmdCreate_Click() Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util L X W") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength For Sheet_Width! = BGW! To EDW! Step ICW! For Sheet_Length! = BGL! To EDL! Step ICL! MainSet.AddNew MainSet!SheetL = Sheet_Length! MainSet!sheetw = Sheet_Width! MainSet.Update Next Next Refresh End Sub Private Sub cmdLengths_Click() SheetWidths! = Val(AddWidths) Call Addparms(2, SheetWidths!) Refresh End Sub Private Sub cmdWidths_Click() SheetLength! = Val(AddLengths) Call Addparms(1, SheetLength!) Refresh End Sub Private Sub Combo12_Change() A$ = UCase$(Combo12.Column(1)) typ$ = "" If InStr(A$, "S/S") <> 0 Then typ$ = "S/S" If InStr(A$, "C/R") <> 0 Then typ$ = "C/R" If InStr(A$, "COLD ROLL") <> 0 Then typ$ = "C/R" If InStr(A$, "ALUMINIUM") <> 0 Then typ$ = "ALZ" If InStr(A$, "ALZ") <> 0 Then typ$ = "ALZ" TypeofMetal = typ$ GaugeOfType = Left$(Combo12.Column(2), 2) Density = Combo12.Column(3) End Sub Private Sub Command109_Click() On Error GoTo Err_Command109_Click Dim stDocName As String Command109.Tag = Command109.Caption Command109.Caption = "Processing" DoEvents DoCmd.SetWarnings (False) lblstatus.Caption = "Building C1 Records" ' stDocName = "Util Make Select 1" ' DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "tricks" If Frame111 = 1 Then stDocName = "Util Result2" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" Else stDocName = "Util Result3" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" End If UtilResult1.SourceObject = "tricks" stDocName = "Util Set non zero usage parts to use" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" stDocName = "Util Set all zero usage parts to ignore" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" Exit_Command109_Click: lblstatus.Caption = "Done" Command109.Caption = Command109.Tag Exit Sub Err_Command109_Click: MsgBox Err.Description Resume Exit_Command109_Click End Sub Private Sub Command122_Click() ' Dim MainDB As Database, MainSet As Recordset Dim sh%(10), sl!(10), Sw!(10), desc$(10) Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Command79.Enabled = True Exit Sub End If Sheets = Val(itsaNull$(NoOfSheets)) a1$ = itsaNull$(FavoriteSet) For i = 1 To Sheets sh%(i) = Val(a1$) cm = InStr(a1$, ",") If cm <> 0 Then a1$ = Mid$(a1$, cm + 1) Else a1$ = "" End If If sh%(i) <> 0 Then Key$ = Right$("0000000000" + Trim$(Str$(sh%(i))), 10) GoSub GetSheetSizer sl!(i) = Sheet_Length! Sw!(i) = Sheet_Width! desc$(i) = Format$(Sheet_Width!, "0.0") + " X " + Format$(Sheet_Length!, "0.0") Else sl!(i) = 0 Sw!(i) = 0 desc$(i) = "" End If Next ' SetNo TotalGw! = 0 MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then FirstValid = 0 BestWt! = 0 BestSheet = 0 Bestlen! = 0 BestWth! = 0 For SetNo = 1 To Sheets Sheet_Length! = sl!(SetNo) Sheet_Width! = Sw!(SetNo) Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) If (FirstValid = 0) And (Gw! <> 0) Then BestWt! = Gw! BestSheet = SetNo Bestlen! = Sheet_Length! BestWth! = Sheet_Width! FirstValid = 1 Exit For End If Next For SetNo = 1 To Sheets Sheet_Length! = sl!(SetNo) Sheet_Width! = Sw!(SetNo) Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) If (BestWt! > Gw!) And (Gw! <> 0) Then BestWt! = Gw! BestSheet = SetNo Bestlen! = Sheet_Length! BestWth! = Sheet_Width! End If Next A$ = MainSet!PartNumber Call UtilGrossWt(BestWth!, Bestlen!, lb_per_sq_ft!, Gw!, Aw!, MainSet) MainSet.Edit If BestSheet = 0 Then MainSet!BestSheetSet = "BAD SHEETSET" Else MainSet!BestSheetSet = desc$(BestSheet) End If MainSet!GrossWt = Gw! MainSet!ActualWt = Aw! MainSet.Update End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Exit Sub GetSheetSizer: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return End Sub Private Sub Command130_Click() tx$ = Trim$(itsaNull$(txtSaveAs)) If tx$ <> "" Then DoCmd.CopyObject , tx$, acTable, "Util Selection C1" End If End Sub Private Sub Command133_Click() Dim MainDB As Database, MainSet As Recordset Dim MainDB2 As Database, MainSet2 As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainDB2 = DBEngine.Workspaces(0).Databases(0) Command133.Tag = Command133.Caption Command133.Caption = "Processing" DoEvents lblstatus.Caption = "Selecting Parts for Material Utilization" DoCmd.RunMacro "Material Selections for Utilitzation" lblstatus.Caption = "Selection Complete" Refresh lblstatus.Caption = "Moving Parts to AS400" Set MainSet = MainDB.OpenRecordset("RMSFILES#_IEMUP1A0") ' Create dynaset. Set MainSet2 = MainDB2.OpenRecordset("Util Selection 2") ' Create dynaset. lblstatus.Caption = "Purging AS400 product number file" On Error Resume Next MainSet.MoveFirst On Error GoTo 0 Do If Not (MainSet.EOF) Then MainSet.Delete DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop lblstatus.Caption = "Purging AS400 result file" MainSet2.MoveFirst Do If Not (MainSet2.EOF) Then p$ = MainSet2!prt MainSet.AddNew MainSet!PRDNO = p$ MainSet.Update DoEvents Else DoEvents Exit Do End If MainSet2.MoveNext Loop lblstatus.Caption = "Activating AS400 Program" DoEvents ActiveXCtl24.DoClick lblstatus.Caption = "Retrieving Results" UtilResult1.SourceObject = "tricks" DoCmd.RunMacro "AS400 Utiliz Results" UtilResult1.SourceObject = "Util Result1" ' lblStatus.Caption = "Calculating material utilization on parts" lblstatus.Caption = "Done" Command133.Caption = Command133.Tag End Sub Private Sub Command136_Click() UtilResult1.SourceObject = "tricks" UtilResult1.SourceObject = "Util Result1" End Sub Private Sub Command67_Click() Cost = PricePerPound * LGrossWt End Sub Private Sub Command68_Click() lblstatus.Caption = "Emptying Util Matrix" DoCmd.CopyObject "Util L X W", acTable, "Util Matrix Zero" End Sub Private Sub Command79_Click() ' Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Dim Prices(4), Rg(4, 2) GoSub InitPricingPerLb Command79.Tag = Command79.Caption Command79.Caption = "Processing" DoEvents Main2Set.Index = "Primary Key" LGrossWt.SetFocus Command79.Enabled = False lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Command79.Enabled = True Exit Sub End If Sheets = Val(itsaNull$(NoOfSheets)) If Sheets > 10 Then MsgBox ("Too Many Sheets") Command79.Enabled = True Exit Sub End If If Sheets < 1 Then MsgBox ("No Sheets Entered") Command79.Enabled = True Exit Sub End If MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then If Val(itsaNull(MainSet!USAGE)) = 0 Then PN$ = MainSet!PartNumber MsgBox ("USAGE=0 for Partnumber: " + PN$) Command79.Enabled = True Exit Sub End If End If Else Exit Do End If MainSet.MoveNext Loop For SetNo = 0 To 10 For i = 0 To 3 For j = 0 To 6 BestSS(SetNo, i, j) = 0 Next Next 'CurrSetSize(SetNo) = 0 Next Cost = 0 ' ' Count up the number of iterations to go through ' NoOfIters% = 0 lblstatus.Caption = "Numbering Iterations" Main2Set.MoveLast Main2Set.Edit Main2Set!idno = "AAA" Main2Set.Update Main2Set.MoveFirst Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Do If Not (Main2Set.EOF) Then NoOfIters% = NoOfIters% + 1 Main2Set.Edit Main2Set!idno = Right$("0000000000" + Trim$(Str$(NoOfIters%)), 10) Main2Set.Update DoEvents Else DoEvents Exit Do End If Main2Set.MoveNext If Not (Main2Set.EOF) Then If (Main2Set!idno = "AAA") Then NoOfIters% = NoOfIters% + 1 Main2Set.Edit Main2Set!idno = Right$("0000000000" + Trim$(Str$(NoOfIters%)), 10) Main2Set.Update Exit Do End If End If Loop Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" lblstatus.Caption = "Calculate Gross weight" If NoOfIters% < Sheets Then MsgBox ("Not Enough Iterations") Command79.Enabled = True Exit Sub End If Iterations = NoOfIters% GoSub Init_Iterations FirstIter = True If NoOfIters% <> 1 Then Do GoSub CalcGWforSet ind = Sheets Do ' This loop bumps the CPH (current place holder) curar(ind) = curar(ind) + 1 If curar(ind) > toar(ind) Then ' IF the CPH exceed the limit fromar(ind) = fromar(ind) + 1 ' start the CPH at the from+1 curar(ind) = fromar(ind) ' and dec back to the prev PH ind = ind - 1 Else ib = curar(ind) ' Otherwise, all PH to the rt For ix = ind To Sheets ' should = CPH+1 curar(ix) = ib ib = ib + 1 Next Exit Do ' done End If Loop dn = 0 For ind = 1 To Sheets ' Check to see if all PHs If curar(ind) <> toar(ind) Then ' = the last toPHs dn = 1 ' if not loop to top Exit For End If Next If dn = 0 Then ' if so do the last one Exit Do End If Loop Else End If GoSub CalcGWforSet Main2Set.MoveFirst Do If Not (Main2Set.EOF) Then BSheet_Width! = Val(Main2Set!sheetw) BSheet_Length! = Val(Main2Set!SheetL) GoSub CalcGWforASheet Sheet_W = BSheet_Width: GoSub Pricing Main2Set.Edit Main2Set!ActualWeight = Format$(TotalAw!, "0.00") Main2Set!GrossWeight = Format$(TotalGw!, "0.00") Main2Set!TotalPrice = Format$(TotalGw! * Price, "0.00") Main2Set!ErrCount = Format$(Terrs!, "0") Main2Set.Update DoEvents Else DoEvents Exit Do End If Main2Set.MoveNext Loop CurrentSheetSet = "" a1$ = "" a2$ = "" ttl# = 0 ttlgw# = 0 ttlaw# = 0 a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Gross Wt" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + Chr$(34) + ";" + Chr$(34) + " Util" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(BestSS(SetNo, 0, 0))), 10) GoSub GetSheetSize a1$ = a1$ + " " + Trim$(Str$(Sheet_Width!)) + "X" + Trim$(Str$(Sheet_Length!)) + " =" + Format$(BestSS(SetNo, 1, 0), "$0") a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Width!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Length!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 1, 0), "$0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 2, 0), "0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 3, 0), "0"), 12) + Chr$(34) + ";" If BestSS(SetNo, 2, 0) = 0 Then ppp = 0 uuu = 0 Else ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0) uuu = (BestSS(SetNo, 3, 0) / BestSS(SetNo, 2, 0)) * 100 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uuu, "0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppp, "0.00000"), 12) + Chr$(34) + ";" ttl# = ttl# + Val(Format(BestSS(SetNo, 1, 0), "0")) ttlgw# = ttlgw# + Val(Format(BestSS(SetNo, 2, 0), "0")) ttlaw# = ttlaw# + Val(Format(BestSS(SetNo, 3, 0), "0")) Next a2$ = a2$ + Chr$(34) + " " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + "Totals " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttl#, "$0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlgw#, "0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlaw#, "0"), 12) + Chr$(34) + ";" If ttlgw# <> 0 Then ppx# = ttl# / ttlgw# uux# = (ttlaw# / ttlgw#) * 100 Else ppx# = 0 uux# = 0 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uux#, "0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppx#, "0.00000"), 12) + Chr$(34) BestSheetSet = a1$ List86.rowSource = a2$ UtilLXW.SourceObject = "tricks" UtilLXW.SourceObject = "Util L X W subform" lblstatus.Caption = "Done" Command79.Enabled = True Command79.Caption = Command79.Tag Exit Sub CalcGWforSet: TotalAw! = 0 TotalGw! = 0 TotalPrc! = 0 a1$ = "" For SetNo = 1 To Sheets a1$ = a1$ + Str$(curar(SetNo)) CurrSetSize(SetNo) = 0 CurrSetGw(SetNo) = 0 CurrSetAw(SetNo) = 0 Next CurrentSheetSet = a1$ MainSet.MoveFirst ' search part file goodset = True Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then ' check the ignore flag BestWt! = 0 BestAw! = 0 BestPrc! = 0 BestSet = 0 For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(curar(SetNo))), 10) GoSub GetSheetSize Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) Sheet_W = Sheet_Width: GoSub Pricing Prc! = Gw! * Price errc = Val(MainSet!CalculationStatus) If errc = 0 Then If (BestPrc! > Prc!) And (Prc! > 0) Then BestWt! = Gw! BestAw! = Aw! BestPrc! = Prc! BestSet = SetNo End If If (BestSet = 0) And (Prc! <> 0) Then BestAw! = Aw! BestWt! = Gw! BestPrc! = Prc! BestSet = SetNo End If End If Next If BestSet = 0 Then goodset = False Exit Do Else TotalAw = BestAw! = TotalAw! TotalGw! = BestWt! + TotalGw! TotalPrc! = BestPrc! + TotalPrc! CurrSetSize(BestSet) = CurrSetSize(BestSet) + BestPrc! CurrSetGw(BestSet) = CurrSetGw(BestSet) + BestWt! CurrSetAw(BestSet) = CurrSetAw(BestSet) + BestAw! End If End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop If goodset Then If FirstIter Then FirstIter = False BestSheetSet = CurrentSheetSet bestsetPrc! = TotalPrc! For top6 = 0 To 6 BestSS(0, 1, top6) = TotalPrc! BestSS(0, 2, top6) = TotalGw! BestSS(0, 3, top6) = TotalAw! Next For SetNo = 1 To Sheets For top6 = 0 To 6 BestSS(SetNo, 0, top6) = curar(SetNo) BestSS(SetNo, 1, top6) = CurrSetSize(SetNo) BestSS(SetNo, 2, top6) = CurrSetGw(SetNo) BestSS(SetNo, 3, top6) = CurrSetAw(SetNo) Next Next End If If (TotalPrc! < BestSS(0, 1, 6)) Then ' if this one is better than then sixth best insert it For worst2best = 5 To 1 Step -1 If (TotalPrc! > BestSS(0, 1, worst2best)) Then For SetNo = 0 To Sheets For top6 = 6 To worst2best + 1 Step -1 BestSS(SetNo, 0, top6) = BestSS(SetNo, 0, top6 - 1) BestSS(SetNo, 1, top6) = BestSS(SetNo, 1, top6 - 1) BestSS(SetNo, 2, top6) = BestSS(SetNo, 2, top6 - 1) BestSS(SetNo, 3, top6) = BestSS(SetNo, 3, top6 - 1) Next Next For SetNo = 1 To Sheets BestSS(SetNo, 0, worst2best + 1) = curar(SetNo) BestSS(SetNo, 1, worst2best + 1) = CurrSetSize(SetNo) BestSS(SetNo, 2, worst2best + 1) = CurrSetGw(SetNo) BestSS(SetNo, 3, worst2best + 1) = CurrSetAw(SetNo) Next BestSS(0, 1, worst2best + 1) = TotalPrc! BestSS(0, 2, worst2best + 1) = TotalGw! BestSS(0, 3, worst2best + 1) = TotalAw! Exit For End If If (TotalPrc! <= BestSS(0, 1, worst2best)) And (worst2best = 1) Then For SetNo = 0 To Sheets For top6 = 6 To worst2best Step -1 BestSS(SetNo, 0, top6) = BestSS(SetNo, 0, top6 - 1) BestSS(SetNo, 1, top6) = BestSS(SetNo, 1, top6 - 1) BestSS(SetNo, 2, top6) = BestSS(SetNo, 2, top6 - 1) BestSS(SetNo, 3, top6) = BestSS(SetNo, 3, top6 - 1) Next Next For SetNo = 1 To Sheets BestSS(SetNo, 0, worst2best) = curar(SetNo) BestSS(SetNo, 1, worst2best) = CurrSetSize(SetNo) BestSS(SetNo, 2, worst2best) = CurrSetGw(SetNo) BestSS(SetNo, 3, worst2best) = CurrSetAw(SetNo) Next BestSS(0, 1, worst2best) = TotalPrc! BestSS(0, 2, worst2best) = TotalGw! BestSS(0, 3, worst2best) = TotalAw! BestSheetSet = CurrentSheetSet BestSS(0, 1, 0) = TotalPrc! For SetNo = 1 To Sheets BestSS(SetNo, 0, 0) = curar(SetNo) BestSS(SetNo, 1, 0) = CurrSetSize(SetNo) BestSS(SetNo, 2, 0) = CurrSetGw(SetNo) BestSS(SetNo, 3, 0) = CurrSetAw(SetNo) Next ' Exit For End If Next End If End If Return GetSheetSize: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return Init_Iterations: For i = 1 To 10 fromar(i) = 0 toar(i) = 0 curar(i) = 0 Next j = Iterations - Sheets For i = 1 To Sheets fromar(i) = i curar(i) = i toar(i) = i + j Next Return CalcGWforASheet: TotalGw! = 0 TotalAw! = 0 Terrs! = 0 MainSet.MoveFirst goodset = True Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then Sheet_Width! = BSheet_Width!: Sheet_Length! = BSheet_Length! Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) errc = Val(MainSet!CalculationStatus) If errc = 0 Then TotalGw! = Gw! + TotalGw! TotalAw! = Aw! + TotalAw! Else goodset = False Terrs! = Terrs! + 1 End If End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Return InitPricingPerLb: ' Dim Prices(4), Rg(4, 2) Prices(1) = Val(GaugeOfType.Column(1)) + Val(itsaNull$(BasePrice)) Prices(2) = Val(GaugeOfType.Column(2)) + Val(itsaNull$(BasePrice)) Prices(3) = Val(GaugeOfType.Column(3)) + Val(itsaNull$(BasePrice)) Prices(4) = Val(GaugeOfType.Column(4)) + Val(itsaNull$(BasePrice)) For i = 1 To 4 r$ = TypeofMetal.Column(i) rx = InStr(r$, "-") If rx = 0 Then Exit For Else Rg(i, 1) = Val(Left$(r$, rx - 1)) Rg(i, 2) = Val(Mid$(r$, rx + 1)) End If Next rgx = i - 1 Return 'Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet Pricing: Price = -1 For i = 1 To rgx If (Sheet_W >= Rg(i, 1)) And (Sheet_W <= Rg(i, 2)) Then Price = Prices(i) Exit For End If Next If Price = -1 Then MsgBox ("Price range error") Stop End If Return End Sub Sub GiveAnswers(Sheets, XSize, Xincs) For i = 1 To Sheets Print Str$((curar(i) - 1) * Xincs + XSize) + " "; Next Print End Sub Private Sub EndLength_LostFocus() Call CalcIters End Sub Private Sub EndWidth_LostFocus() Call CalcIters End Sub Private Sub Form_Open(Cancel As Integer) Dim MainDB As Database, MainSet As Recordset, tables As TableDef Set MainDB = DBEngine.Workspaces(0).Databases(0) Set tables = MainDB.TableDefs(0) cnt = MainDB.TableDefs.Count bb$ = "" For i = 0 To cnt - 1 Set tables = MainDB.TableDefs(i) bb$ = bb$ + tables.name + ";" Next List158.rowSource = bb$ End Sub Private Sub IncLength_LostFocus() Call CalcIters End Sub Private Sub IncWidth_LostFocus() Call CalcIters End Sub Private Sub cmdOpen14two_Click() On Error GoTo Err_cmdOpen14two_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "14 two" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdOpen14two_Click: Exit Sub Err_cmdOpen14two_Click: MsgBox Err.Description Resume Exit_cmdOpen14two_Click End Sub Private Sub Addparms(i%, Sizeses!) Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util L X W") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength If i% = 1 Then BG! = BegWidth ed! = EndWidth IC! = IncWidth Else BG! = BegLength ed! = EndLength IC! = IncLength End If For SS! = BG! To ed! Step IC! If i% = 1 Then SheetWidth! = SS! SheetLength! = Sizeses! Else SheetWidth! = Sizeses! SheetLength! = SS! End If MainSet.AddNew MainSet!SheetL = SheetLength! MainSet!sheetw = SheetWidth! MainSet.Update Next Refresh End Sub Public Sub GetTheBestAnswers() Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" A = BestSheets If BestSS(1, 0, 0) = 0 Then Exit Sub End If a1$ = "" a2$ = "" ttl# = 0 ttlgw# = 0 ttlaw# = 0 a3$ = "" a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Gross Wt" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + Chr$(34) + ";" + Chr$(34) + " Util" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(BestSS(SetNo, 0, A))), 10) GoSub GetTheSheetSize a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Width!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Length!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 1, A), "$0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 2, A), "0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 3, A), "0"), 12) + Chr$(34) + ";" If BestSS(SetNo, 2, 0) = 0 Then ppp = 0 uuu = 0 Else ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0) uuu = (BestSS(SetNo, 3, 0) / BestSS(SetNo, 2, 0)) * 100 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uuu, "0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppp, "0.00000"), 12) + Chr$(34) + ";" ttl# = ttl# + Val(Format(BestSS(SetNo, 1, A), "0")) ttlgw# = ttlgw# + Val(Format(BestSS(SetNo, 2, A), "0")) ttlaw# = ttlaw# + Val(Format(BestSS(SetNo, 3, A), "0")) a3$ = a3$ + Trim$(BestSS(SetNo, 0, A)) + "," Next a3$ = Left$(a3$, Len(a3$) - 1) a2$ = a2$ + Chr$(34) + " " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + "Total " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttl#, "$0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlgw#, "0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlaw#, "0"), 12) + Chr$(34) + ";" If ttlgw# <> 0 Then ppx# = ttl# / ttlgw# uux# = (ttlaw# / ttlgw#) * 100 Else ppx# = 0 uux# = 0 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uux#, "0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppx#, "0.00000"), 12) + Chr$(34) List86.rowSource = a2$ FavoriteSet = a3$ Exit Sub GetTheSheetSize: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return End Sub Private Sub Command108_Click() On Error GoTo Err_Command108_Click Dim stDocName As String Dim stLinkCriteria As String Command108.Tag = Command108.Caption Command108.Caption = "Processing" DoEvents stDocName = "Util Select picker" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_Command108_Click: Command108.Caption = Command108.Tag Exit Sub Err_Command108_Click: MsgBox Err.Description Resume Exit_Command108_Click End Sub Private Sub Command110_Click() On Error GoTo Err_Command110_Click Dim stDocName As String Command110.Tag = Command110.Caption Command110.Caption = "Processing" DoEvents lblstatus.Caption = "Obtaining Records" DoCmd.SetWarnings (False) stDocName = "Util Make Select 0" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Flag Update" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Make Select 1" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Make Select 2" DoCmd.OpenQuery stDocName, acNormal, acEdit lblstatus.Caption = "Done" Exit_Command110_Click: Command110.Caption = Command110.Tag Exit Sub Err_Command110_Click: MsgBox Err.Description Resume Exit_Command110_Click End Sub Private Sub Command134_Click() On Error GoTo Err_Command134_Click x = Detail.BackColor Detail.BackColor = QBColor(15) DoCmd.PrintOut acPages, 1, 1, acHigh, 1 Detail.BackColor = x Exit_Command134_Click: Exit Sub Err_Command134_Click: MsgBox Err.Description Resume Exit_Command134_Click End Sub Private Sub Restore_C1_File_Click() tx$ = Trim$(itsaNull$(List158)) If tx$ <> "" Then DoCmd.SetWarnings (False) lblstatus.Caption = "Copying C1 Records" ' stDocName = "Util Make Select 1" ' DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "tricks" DoCmd.CopyObject , "Util Selection C1", acTable, tx$ UtilResult1.SourceObject = "Util Result1" End If End Sub ``` ## What it does **VBA Code Description** This VBA code is written in Excel and appears to be part of a larger application used for material utilization calculations. The code is organized into several subroutines that perform different tasks, such as calculating iterations, selecting parts for material utilization, moving parts to an AS400 system, and calculating sheet sizes. **CalcIters Subroutine** This subroutine calculates the number of iterations required to move a certain amount of material along a sheet. It takes into account the width and length of the sheet, as well as any incremental changes (IncWidth and IncLength). The calculation involves: * Calculating the absolute difference between the end and beginning values for width and length * Dividing the difference by the increment value (if non-zero) * Adding 1 to the result * Squaring the result of the first operation The number of iterations is then formatted as a zero-padded string and stored in the `Iterations` variable. **cmdButtnCalc_Click Subroutine** This subroutine performs several tasks: 1. **Material Selections for Utilitzation**: Runs a macro to select parts for material utilization. 2. **Purging AS400 product number file**: Moves all records from the "RMSFILES#_IEMUP1A0" table in the MainDB database and deletes them. 3. **Purging AS400 result file**: Moves all records from the "Util Selection 2" table in the MainDB2 database, adds new records with the corresponding product number, and updates the existing records. 4. **Activating AS400 Program**: Runs a macro to activate an AS400 program (ActiveXCtl24.DoClick). 5. **Retrieving Results**: Runs another macro to retrieve results from the AS400 system (AS400 Utiliz Results). The subroutine also updates several variables (`BegWidth`, `EndWidth`, etc.) and uses them to calculate sheet sizes. **Command25_Click Subroutine** This subroutine performs several tasks: 1. **Getting MainDB and MainSet**: Opens a database and recordset for material utilization. 2. **Getting Main2DB and Main2Set**: Opens another database and recordset for the AS400 system. 3. **Setting variables**: Sets various variables, including sheet width, length, and density. 4. **Looping through sheet sizes**: Loops through possible sheet widths and lengths, calculating total gross weight and updating records in Main2Set. 5. **Calculating sheet size**: Calls a subroutine (DoSheetSize) to calculate the gross weight for all parts at each sheet size. The subroutine also updates several variables (`TotalGw`, `LSheetL`, `LSheetW`) and uses them to store results. **DoSheetSize Subroutine** This subroutine calculates the gross weight for all parts at a given sheet size. It: * Moves to the first record in MainSet * Calculates the total gross weight by summing up the weights of all records * Updates the `TotalGw`, `LSheetL`, and `LSheetW` variables with the calculated values The subroutine also updates the status label (`lblstatus`) to indicate that the calculation is in progress.