Chronos - Sum Product | Mining University

Chronos - Sum Product

The first thing I want to do with every Chronos workbook I have ever made is to take each 'WEIGHT' variable in the Reserve sheet and insert a column that multiplies it by the weighting field.  In most cases this is taking the grade and multiplying it by the tons.  Now I finally have a script that does this and it's pretty quick. 
The trick to getting this to run in an acceptable time frame for large numbers of columns was to turn off the screen update and the automatic calculation.  I just tested this on a workbook that has 1,600 columns and the script took about a minute to run.

There are some assumptions that this script makes.  First, it assumes that the 'WEIGHT' columns are to the left of the field by which they are weighted.  Second, it assumes that you haven't manually added any columns that are labeled as type 'WASTE' and don't have a 'weight by' field (yes I actually did this).  Other than that I think it works pretty well.  Let me know if it works for you.

To run the script, copy the code below and paste it into a VBA macro for excel.

Sub ounces()
'insert columns and calculate ounces contained based on the grade and total mass
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LastColumn, ColumnHeader, LastRow, GradeColumn, WeightColumn, Equation, StartFill, EndFill, CurrentCell, MassHeader
LastColumn = ActiveCell.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).row
Range("a2").Select
While (ActiveCell.Column < LastColumn)
  If ActiveCell = "WEIGHT" Then
    ColumnHeader = ActiveCell.Offset(-1, 0)
    GradeColumn = Split(ActiveCell.Offset(2, 1).Address, "$")
'    MsgBox (GradeColumn(1))
'    MassColumn = Split(ActiveCell.Offset(3, 7).Address, "$")
    ActiveCell.EntireColumn.Select
    Selection.Insert shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
    LastColumn = LastColumn + 1
    ActiveCell = ColumnHeader & " CONTAINED"
    ActiveCell.Offset(1, 0).Select
    ActiveCell = "SUM"
    ActiveCell.Offset(2, 0).Select
    StartFill = ActiveCell.Address
    EndFill = Split(StartFill, "$")(1)
'    MsgBox (EndFill)
    CurrentCell = ActiveCell.Address
    ActiveCell.Offset(-3, 1).Select
    MassHeader = ActiveCell.Offset(2, 0)
'    MsgBox (MassHeader)
    While (ActiveCell <> MassHeader)
      ActiveCell.Offset(0, 1).Select
    Wend
    WeightColumn = Split(ActiveCell.Address, "$")
'    MsgBox (GradeColumn(1))
'    MsgBox (WeightColumn(1))
    Range(CurrentCell).Select
    Range(ActiveCell, Split(ActiveCell.Address, "$")(1) & LastRow) = "=" & GradeColumn(1) & "4*" & WeightColumn(1) & "4"
    ActiveCell.Offset(-2, 1).Select
  End If
  ActiveCell.Offset(0, 1).Select
Wend
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

6 comments:

  1. The script looks really good but it keeps freezing Excel. I think it must be stuck in a loop somewhere.. eh?

    ReplyDelete
    Replies
    1. Please see the comment by another anonymous poster below. The screen updating functionality was accidentally left turned off in the script. I have fixed the text in the original post to fix this.
      Sorry about the confusion.

      Delete
  2. I think it is because screen updating is set to false at the end of the script so the workbook would appear to be inactive.

    ReplyDelete
    Replies
    1. Oh no!
      I can't believe that I left that off.
      In order to have the script run faster I turn off cell calculation and screen updating at the beginning of the script using:

      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False

      At the end of the script I turn cell calculation and screen updating back on (or I meant to) using:

      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True

      The way it appears in the original post it will definitely not appear to have done anything because I forgot to turn screen updating back on. I will change this in the original post so that others don't have this same problem.

      Delete
  3. This comment has been removed by a blog administrator.

    ReplyDelete
  4. This comment has been removed by a blog administrator.

    ReplyDelete