It's alot. If there is a better way to post it, let me know.
‘The following public variables are in a separate module from the rest of
the code:
Public x As Variant
Public rngChange As Range
Public RangeCountTotal As Long
Public iCountCurrent As Integer
========================
Option Explicit
Sub procTestGoalSeek()
Dim rngResult As Range
Dim vTarget As Variant
Dim vaResult As Variant
Dim TopRow As Long
Dim BottomRow As Long
Dim RangeToChange As Range
Dim rng As Range
Dim wks As Worksheet
Application.EnableEvents = True
'Get current calculation mode and store as variable, then set to manual for
faster code
x = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo HandleCancelOut
Application.EnableCancelKey = xlErrorHandler
'Determine # of rows to estimate amount of time to do goal seek
RangeCountTotal = Range(Range("G3"), Range("G65536").End(xlUp)).Count -
Application.CountBlank(Range(Range("G3"), Range("G65536").End(xlUp))) -
Range("AV:AV").Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Count
Dim RangeCountTimeMinimum As String
Dim RangeCountTimeMaximum As String
Dim RangeCountTimeBasisMin As String
Dim RangeCountTimeBasisMax As String
RangeCountTimeBasisMin = "minutes"
RangeCountTimeBasisMax = "minutes"
RangeCountTimeMinimum = Format(RangeCountTotal * 5 / 60, "#.00") 'Gives you
minimum estimated time, in minutes
RangeCountTimeMaximum = Format(RangeCountTotal * 12 / 60, "#.00") 'Gives you
maximum estimated time, in minutes
If RangeCountTimeMinimum > 60 Then 'If minimum estimated time is > 60
minutes, then express in hours
RangeCountTimeMinimum = Format(RangeCountTimeMinimum / 60, "#.0")
RangeCountTimeBasisMin = "hours"
End If
If RangeCountTimeMaximum > 60 Then 'If maximum estimated time is > 60
minutes, then express in hours
RangeCountTimeMaximum = Format(RangeCountTimeMaximum / 60, "#.0")
RangeCountTimeBasisMax = "hours"
End If
StartAgain:
vTarget = InputBox(prompt:="Have you entered ALL of your inventory data and
closed all other Excel workbooks? If not, select 'Cancel' and do that first.
" & _
"If you have and are ready to proceed, enter your desired gross profit %
below; for example, enter 35.5 for 35.5%. " & _
vbNewLine & _
vbNewLine & "IMPORTANT: " & _
vbNewLine & "o Estimated process time is between " &
RangeCountTimeMinimum & _
vbNewLine & " " & RangeCountTimeBasisMin & " and " &
RangeCountTimeMaximum & " " & RangeCountTimeBasisMax & "." & _
vbNewLine & "o Once processing starts, hit the 'ESC' key " & _
vbNewLine & " twice to cancel out, and any rows already" & _
vbNewLine & " done will be retained." & _
vbNewLine & "o Any values now in Column AB will be" & _
vbNewLine & " overwritten. " & _
vbNewLine & "o Any rows with an error result in Col AV" & _
vbNewLine & " will be skipped.", Title:="ENTER DESIRED GP % FOR HW")
On Error Resume Next
If IsNumeric(vTarget) Then
'Initialize a count for what row Excel is working on
iCountCurrent = 0
vTarget = vTarget / 100
Set wks = Worksheets("MMS HW")
With wks
Set RangeToChange = Range(Range("G3"), Range("G65536").End(xlUp))
RangeCountTotal = RangeToChange.Count -
Application.CountBlank(Range(Range("G3"), Range("G65536").End(xlUp))) -
Range("AV:AV").Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Count
End With
For Each rng In RangeToChange
If Trim(rng.Value) <> "" Then
If IsError(Range("AV" & rng.row).Value) = False Then
Set rngChange = Range("AB" & rng.row) 'DISCOUNT % THAT NDS TO
BE CALCULATED TO GET TO DESIRED GP %
Set rngResult = Range("AV" & rng.row) 'GP % RESULT DESIRED
vaResult = funGoalSeek(oChangeCell:=rngChange,
oResultCell:=rngResult, dTargetVaue:=CDbl(vTarget))
End If
End If
Next
Else
If MsgBox("Invalid input. Please enter numbers only!", vbInformation +
vbOKCancel) = vbOK Then
GoTo StartAgain
Else
GoTo HandleCancelOut
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.StatusBar = "" 'Remove custom message
Application.StatusBar = False 'Return control of the status bar to Excel
Application.DisplayStatusBar = True 'Display the status bar
Application.Iteration = False ‘force not to use iteration in dealing with
circular references and use F9 instead
Application.Calculation = xlCalculationAutomatic
Application.Calculation = x
Exit
HandleCancelOut:
MsgBox ("Cancelled; thanks."), vbOKOnly, "PROCESSING STOPPED BY USER"
Application.StatusBar = "" 'Remove custom message
Application.StatusBar = False 'Return control of the status bar to Excel
Application.DisplayStatusBar = True 'Display the status bar
Application.Iteration = False 'Force not to use iteration in dealing with
circular references and use F9 instead
Application.Calculation = x
Application.EnableEvents = True
Application.ScreenUpdating = True
Call sndPlaySound32("C:\Windows\Media\chimes.wav", 0)
Application.Calculation = xlCalculationAutomatic
Application.Calculation = x
End
End Sub
'***************************************************************************
'The passed parameters are:
'oChangeCell - A range object for the cell that is to be changed.
'oResultCell - A range object for the cell that contains the result to be
found.
'dTargetVaue - The number to seek for.
'dFirstGuess - Optional number for the first iteration.
'dAccuracy - Optional number for the desired dAccuracy, defined as <new
value> - <old value>
'fPositive - Optional boolean flag to restrict the changing cell to
fPositive values. This
' is useful when goal seeking using a percentage change in a variable.
'***************************************************************************
Function funGoalSeek(oChangeCell, oResultCell, dTargetVaue, _
Optional dFirstGuess, Optional dAccuracy, Optional fPositive)
Dim fStatus As Boolean
Dim dStart As Double, dStop As Double
Dim dValue1 As Double, dValue2 As Double, dValue3 As Double
Dim dResult1 As Double, dResult2 As Double
Dim iCount As Integer, sMsg As String
'On Error Resume Next
On Error GoTo HandleCancel
Application.EnableCancelKey = xlErrorHandler
'Initialize the optional numbers
If IsMissing(dAccuracy) Then
dAccuracy = 0.000001
End If
If IsMissing(fPositive) Then
fPositive = False
End If
'Get current status bar display, display it and freeze the screen
fStatus = Application.DisplayStatusBar
Application.StatusBar = "CALCULATING ..."
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.ScreenUpdating = True
'**************************************************************************
'Perform goal seek
'**************************************************************************
'Get the initial values
dValue1 = oChangeCell.Value
'Calculate the sheet to get the initial result.
dResult1 = funGoalCalc(oChangeCell, dValue1, oResultCell)
dResult2 = dResult1
'If the initial result is the solution, exit
If Abs(dResult2 - dTargetVaue) < dAccuracy Then
GoTo Ptr_After_Loop
End If
'Use the current value and 2% more than the current value for first two
points. Store the inital result
If IsMissing(dFirstGuess) Then
If dValue1 = 0 Then
dValue2 = 0.5
Else
dValue2 = dValue1 * 1.02
End If
Else
dValue2 = dFirstGuess
End If
'Initialize a counter for the iterations
iCount = 1
'Initialize a counter for the status bar
iCountCurrent = iCountCurrent + 1
'Display a status message
Application.StatusBar = "NOW WORKING ON #" & iCountCurrent & " OF " &
RangeCountTotal & ". IF DESIRED, PRESS ESC TWICE TO STOP PROCESSING."
'Loop for each iteration
Do
'Get the new result
dResult2 = funGoalCalc(oChangeCell, dValue2, oResultCell)
iCount = iCount + 1
'If the result has been reached, quit
If Abs(dResult2 - dTargetVaue) < dAccuracy Then
Exit Do
End If
'If the result is not changing, quit
If Abs(dResult2 - dResult1) < dAccuracy Then
GoTo Ptr_After_Loop
End If
'If a discontinutity has been found, display a message and quit
If Sgn(dResult2 - dTargetVaue) = Sgn(dResult1 - dTargetVaue) And
Abs(dResult2 - dTargetVaue) > Abs(dResult1 - dTargetVaue) And iCount > 2 Then
sMsg = "A problem has been encountered; sorry, Excel has to stop
processing."
GoTo Ptr_After_Loop
End If
'Get the new guess, using linear interpolation/extrapolation
' x=(y*(x2-x1)+(x1*y2-x2*y1))/(y2-y1)
dValue3 = (dTargetVaue * (dValue2 - dValue1) + dValue1 * dResult2 -
dValue2 * dResult1) / (dResult2 - dResult1)
'If the new guess is negative, and the "Restrict to fPositive" flag is
set, use half of the previous guess
If dValue3 < 0 And fPositive = True Then
dValue3 = dValue2 / 2
End If
'Store the variables for the next loop
dValue1 = dValue2
dResult1 = dResult2
dValue2 = dValue3
'Loop forever - the If statements will quit the loop
Loop While True
Ptr_After_Loop:
'Return the status bar to its normal state
Application.DisplayStatusBar = fStatus
Application.StatusBar = False
HandleCancel:
If Err = 18 Then
If MsgBox("Do you want to stop? If you answer 'Yes', processing will
stop and the cell currently being calculated will be set to blank.", vbYesNo,
"QUIT?") = vbYes Then
rngChange.Value = ""
Application.StatusBar = "RECALCULATING..."
ActiveSheet.Calculate
Application.StatusBar = "" 'Remove custom message
Application.StatusBar = False 'Return control of the status bar to
Excel
Application.DisplayStatusBar = True 'Display the status bar
Application.Iteration = False 'force not to use iteration in dealing
with circular references and use F9 instead
' Application.Calculation = x
Application.EnableEvents = True
Application.ScreenUpdating = True
Call sndPlaySound32("C:\Windows\Media\chimes.wav", 0)
Application.Calculation = xlCalculationAutomatic
Application.Calculation = x
End
Else
Resume
End If
End If
End Function
'**************************************************************************
'Routine to calculate the result for each iteration of the goal seek
procedure.
'***************************************************************************
Function funGoalCalc(oChng, vVal, oRes)
'Store the new guess in the sheet
oChng.Value = vVal
'Recalculate the sheet
ActiveSheet.Calculate
'Read off the result and return the value
funGoalCalc = oRes.Value
End Function
