'Solver Statistics Macro 'Version 0 (Version 1 was in xlm)



Pobieranie 28.94 Kb.
Data03.05.2016
Rozmiar28.94 Kb.


'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) <= 0 Then 'Diagonal elements must not be zero or negative.

MsgBox "Błąd odwracania macierzy (type 1)." & Chr(13) & Chr(13) & "Zatrzymanie programu.", 16, "UNKNOWN ERROR"

Exit Sub

End If


Next

On Error GoTo 0

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

'Set up area for returned data. 2 cols are needed if there is only one parm. (TRUE is evaluated as -1)

Step4: On Error GoTo InputErrorHandler:

Set ReturnArray = Application.InputBox("Zaznacz obszar składający się z 3-wieszy i " & N3 - (N3 = 1) & _

" kolumn" & Chr(13) & "w celu podania wyników.", "SOLVER STATISTICS - Krok 4 z 4", , , , , , 8)

On Error GoTo 0

Ra = ReturnArray.Row

Ca = ReturnArray.Column

Rows_a = ReturnArray.Rows.Count

Cols_a = ReturnArray.Columns.Count

If Rows_a > 3 Or Cols_a > N3 - (N3 = 1) Then

MsgBox "Zaznaczyłeś obszar z więcej niż 3 wierszami lub " & N3 - (N3 = 1) & " kolumnami." & Chr(13) & Chr(13) _

& "Zaznacz ponownie", 16, "INPUT ERROR"

GoTo Step4

End If

If Cols_a < N3 Then



MsgBox "Zaznaczyłeś obszar zawierający mniej niż " & N3 & " kolumn." & Chr(13) & Chr(13) & " Zaznacz ponownie", 16, "INPUT ERROR"

GoTo Step4

End If

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



'Calculate standard deviations and send results back.

For j = 1 To N3

StdErr = Sqr(InvArray(j, j)) * RMSD

Cells(Ra, Ca + j - 1).Value = ParmValu(j)

Cells(Ra + 1, Ca + j - 1).Value = StdErr

Next


Cells(Ra + 2, Ca).Value = CorrelCoeff

Cells(Ra + 2, Ca + 1).Value = RMSD

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

'Error Handler for case when Cancel button is pressed in dialog boxes

InputErrorHandler: Exit Sub

MatInvErrorHandler: MsgBox "Błąd odwracania macierzy (typ 2)." & Chr(13) & Chr(13) & "Zatrzymanie programu.", 16, "UNKNOWN ERROR"


End Sub

'==============================================================Sub AUTO_OPEN() 'INSTALLS MENU COMMAND


'Activate the workbook, then Hide it

Workbooks("SolvStat.xls").Activate

ActiveWindow.Visible = False
'Check to see if command has already been installed.

For Each CMD In MenuBars(xlWorksheet).Menus("Tools").MenuItems

If CMD.Caption = "Solver Statistics..." Then Exit Sub

Next
'Check to see if Solver has already been installed.

NoSolver = True

For Each CMD In MenuBars(xlWorksheet).Menus("Tools").MenuItems

If CMD.Caption = "Sol&ver..." Then NoSolver = False

Next
If NoSolver = True Then

With MenuBars(xlWorksheet).Menus("Tools").MenuItems.Add(Caption:="-", OnAction:="", before:=1)

End With


With MenuBars(xlWorksheet).Menus("Tools").MenuItems.Add(Caption:="Solver Statistics...", _

OnAction:="SolvStat", before:=1)

End With

Else


Position = MenuBars(xlWorksheet).Menus("Tools").MenuItems("Sol&ver...").Index 'Get position of "Solver." in menu

With MenuBars(xlWorksheet).Menus("Tools").MenuItems.Add(Caption:="Solver Statistics...", _

OnAction:="SolvStat", before:=Position + 1)

End With


With MenuBars(xlWorksheet).Menus("Tools").MenuItems.Add(Caption:="-", _

OnAction:="", before:="Sol&ver...")

End With

End If
End Sub



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






©absta.pl 2019
wyślij wiadomość

    Strona główna