'Solver Statistics macro



'Solver Statistics Macro

'Version 2.0 (Version 1.1 was in XLM)

'Begun 12/31/97. Last modified 1/13/98

'Copyright 1995, 1998 E. J. Billo

'==============================================================

‘Calculates standard errors for regression coefficients obtained by using the Solver.

'See "Excel for Chemists" by E. J. Billo, Chapter 17.

'Installs new menu command "Solver Statistics... " in Tools menu.

'Known_y's and calc_y's must each be in a single row or column.

'Regression parameters (Solver's Changing Cells) can be in non-adjacent cells.

'SolvStat returns the following array of regression parameters:

'(The regression parameters are not calculated by SolvStat, merely echoed to indicate the order of their selection)

'parm(x) parm(y) ... parm(z)

'std.dev.(x) std.dev.(y) ... std.dev.(z)

'R^2 SE(y)

'================================================================================

Option Base 1 'All arrays begin with array index 1

'================================================================================

Sub SolvStat()

If Left(Application.OperatingSystem, 3) = "Win" Then KeyText = "CTRL" Else KeyText = "COMMAND"

msg1 = Chr(13) & Chr(13) & "(Range must be a single row or column.)"

msg2 = Chr(13) & "(Cells can be non-adjacent, in which case hold down the " & KeyText & _

" key while selecting, or enter a comma between selections.)"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim YObsd(), YCalc(), ParmValu(), PartialDeriv(), Product(), ProdArray()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Read in address of known y's & check for errors

Step1: On Error GoTo InputErrorHandler 'Handle error caused when Cancel button is pressed.

Set known_ys = Application.InputBox("Podaj zakres doświadczalnych wartości Y." & msg1, "SOLVER STATISTICS - STEP 1 OF 4", , , , , , 8)

On Error GoTo 0 'Now OK to turn off error handler.

Rows_ky = known_ys.Rows.Count

Cols_ky = known_ys.Columns.Count

If Rows_ky > 1 And Cols_ky > 1 Then 'Check for bad input.

MsgBox "Doświadczalne wartości Y muszą się znajdować w jednym wierszu lub kolumnie." & Chr(13) & Chr(13) & "Zaznacz ponownie ", 16, "INPUT ERROR"

GoTo Step1

End If

N1 = known_ys.Count

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Read in address of calculated y's & check for errors

Step2: On Error GoTo InputErrorHandler

Set calc_ys = Application.InputBox("Podaj zakres wartości Y obliczonych z modelu." & msg1, "SOLVER STATISTICS - Krok 2 z 4", , , , , , 8)

On Error GoTo 0

Rcy = calc_ys.Row

Ccy = calc_ys.Column

Rows_cy = calc_ys.Rows.Count

Cols_cy = calc_ys.Columns.Count

If Rows_cy > 1 And Cols_cy > 1 Then

MsgBox "Obliczone z modelu wartości Y muszą się znajdować w jednym wierszu lub kolumnie." & Chr(13) & Chr(13) & "Zaznacz ponownie ", 16, "INPUT ERROR"

GoTo Step2

End If

N2 = calc_ys.Count

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'More error checking on known y's and calc y's

If N1 N2 Then

MsgBox "Liczba zaznaczonych doświadczalnych wartości Y musi być równa liczbie zaznaczonych obliczonych wartości Y." & Chr(13) & Chr(13) & _

"Zaznacz ponownie", 16, "INPUT ERROR"

GoTo Step1

End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Save Y(obsd) and Y(calc) data internally. Check to make sure Y(calc) are formulas

N = N1

ReDim YObsd(N), YCalc(N)

x = 1

For Each F In known_ys '

YObsd(x) = F.Value 'Save the Y(obsd) values in an array.

x = x + 1

Next

x = 1

For Each F In calc_ys

If Left(F.Formula, 1) "=" Then

MsgBox "Obliczone z modelu wartości Y musi być zapisane jako wzór." & Chr(13) & Chr(13) & "Podaj poprawny wzór do obliczania Y", 16, "INPUT ERROR"

GoTo Step2

End If

YCalc(x) = F.Value

x = x + 1

Next

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Read in addresses of parms & check for errors

Step3: On Error GoTo InputErrorHandler:

Set Parms = Application.InputBox("Zaznacz komórki zawierające współczynniki obliczone metodą najmniejszych kwadratów przez Solvera." & msg2, _

"SOLVER STATISTICS – Krok 3 z 4", , , , , , 8)

On Error GoTo 0

N3 = Parms.Count

If N3 >= N Then

MsgBox "Liczba punków doświadczalnych musi być większa niż liczba obliczanych współczynników regresji." & Chr(13) & Chr(13) & _

"Zatrzymanie obliczeń ", 16, "INPUT ERROR"

Exit Sub

End If

ReDim ParmValu(N3), PartialDeriv(N, N3), Product(N, N3, N3), ProdArray(N3, N3)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Save parms to internal table. Check to make sure they are not formulas.

x = 1

For Each cell In Parms

If (Not (IsNumeric(cell))) Or cell.Value = "" Then

MsgBox "Jedna lub więcej komórek została zaznaczona niepoprawnie (Niektóre z tych komórek te nie zawierają liczb.)." & Chr(13) & Chr(13) & _

"Wybierz ponownie ", 16, "INPUT ERROR"

GoTo Step3

End If

ParmValu(x) = cell.Value

x = x + 1

Next

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Calculate SS(resid), SS(regression), RMSD and correlation coefficient

Ybar = Application.Average(known_ys)

SSresiduals = 0: SSregression = 0

For x = 1 To N

SSresiduals = SSresiduals + (YCalc(x) - YObsd(x)) ^ 2

SSregression = SSregression + (Ybar - YCalc(x)) ^ 2

Next

CorrelCoeff = SSregression / (SSregression + SSresiduals)

RMSD = Sqr(SSresiduals / (N - N3))

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Calculate table of partial differentials

increment = 0.000001

'1E-6 seems to be optimum value for increment for numerical differentiation.

'1E-3 is too large, 1E-12 is too small. 1E-9 gives results almost identical to 1E-6.

y = 1

For Each parm In Parms

parm.Value = parm * (1 + increment) 'Increase regression coeffs by a small increment.

If parm = 0 Then parm.Value = 1E-100 'If cell contains zero exactly, replace it with very small value

CheckErrorSum = 0

x = 1

For Each cell In calc_ys

PartialDeriv(x, y) = (cell - YCalc(x)) / (parm * increment) 'Partial deriv = delta(function)/delta(parameter)

CheckErrorSum = CheckErrorSum + PartialDeriv(x, y) 'This sum used only for error checking.

x = x + 1

Next cell

parm.Value = ParmValu(y) 'Restore original parameter value

If CheckErrorSum = 0 Then

MsgBox "Błąd w obliczeniach macierzy." & Chr(13) & Chr(13) & "Najpowszechniejsze błędy: " & Chr(13) & Chr(13) & _

"1. Niepoprawny wybór komórek Y(obl)." & Chr(13) & Chr(13) & _

"2. Niepoprawny wybór komórek zawierających współczynniki regresji " & Chr(13) & Chr(13) & "Zatrzymanie programu.", 16, "UNKNOWN ERROR"

Exit Sub

End If

y = y + 1

Next parm

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Calculate table of products of partial differentials. Set up matrix of sums of cross-products.

For y = 1 To N3

For z = y To N3

SumProduct = 0

For x = 1 To N

SumProduct = SumProduct + PartialDeriv(x, y) * PartialDeriv(x, z)

Next x

ProdArray(y, z) = SumProduct

ProdArray(z, y) = SumProduct

Next: Next

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Invert matrix. Check for errors

On Error GoTo MatInvErrorHandler

InvArray = Application.MInverse(ProdArray)

For j = 1 To N3

If InvArray(j, j) ................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download