Option Explicit
Option Base 1
Function ExFx(ByVal sFx As String, ByRef x() As Variant, _
ByRef y() As Variant, _
ByVal i As Integer, ByVal NumIVars As Integer) As Double
Dim J As Integer
' replace Xnn starting with the higher indices just in case there
' are more than 9 variables.
sFx = UCase(sFx)
For J = NumIVars To 1 Step -1
sFx = Replace(sFx, "X" & J, "(" & x(i, J) & ")")
Next J
sFx = Replace(sFx, "Y", "(" & y(i, 1) & ")")
ExFx = Evaluate(sFx)
End Function
Sub BestMLR2()
Const MAX_ERRORS As Double = 1000000# ' initial max error value
Dim ErrorCounter As Double, MaxErrors As Double, sMaxErr As String
Dim NumIndpVars As Integer ' number of independent variables
Dim TN As Integer ' total number of variables = NIV+1
Dim N As Integer ' number of data points
Dim MaxTrans As Integer ' max transformations
Dim MaxResults As Integer ' max results
Dim Col1 As Integer, Col2 As Integer, Col3 As Integer
Dim Col4 As Integer, Col5 As Integer
Dim i As Integer, J As Integer, K As Integer
Dim M1 As Integer, M As Integer
Dim VarIdx As Integer, Low As Integer, Hi As Integer
Dim TransfMat() As String, sFx As String
Dim CurrentTransf() As String, CountTransf() As Integer
Dim NumTransf() As Integer ' number of transformations
Dim y() As Variant, x() As Variant
Dim Yt() As Variant, Xt() As Variant
Dim vRegResultsMat As Variant
Dim F As Double, Rsqr As Double, xval As Double
Dim fMaxCount As Double, fCount As Double, fMilestone As Double
Dim dt1 As Date, dt2 As Date
Dim answer As Integer
Dim answer2 As Integer
Dim myValue As Variant
answer = MsgBox("Are the number of X Variables correct?", vbYesNo + vbQuestion, _
"Check Number of X Variables")
If answer = vbYes Then
dt1 = Now
ErrorCounter = 0
MaxErrors = MAX_ERRORS
NumIndpVars = [a2].Value
MaxResults = [A4].Value
TN = NumIndpVars + 1
Col1 = 2 ' first column of data
Col2 = Col1 + TN + 1 ' first column of transformations
Col3 = Col2 + TN + 1 ' first column of results
Col4 = Col3 + TN + 1 ' first column of tranformatioons
Col5 = Col4 + TN - 1 ' last column of transformations
Range(Cells(2, Col3), Cells(1 + 2 * MaxResults, Col3 + 3 * TN)).Value = ""
Range(Cells(2, Col3), Cells(1 + MaxResults, Col3 + 1 + TN)).Value = 0
MaxTrans = Range(Cells(2, Col2), Cells(1, Col2)).CurrentRegion.Rows.Count - 1
ReDim NumTransf(TN), TransfMat(TN, MaxTrans), CurrentTransf(TN)
ReDim CountTransf(TN)
fMaxCount = 1
For i = 1 To TN
J = 2
Do While Trim(Cells(J, Col2 + i - 1)) <> ""
TransfMat(i, J - 1) = Cells(J, Col2 + i - 1)
J = J + 1
Loop
NumTransf(i) = J - 2
fMaxCount = fMaxCount * NumTransf(i)
Next i
N = Range("B1").CurrentRegion.Rows.Count - 1
y = Range("B2:B" & N + 1).Value
x = Range(Cells(2, 3), Cells(N + 1, 2 + NumIndpVars)).Value
Yt = Range("B2:B" & N + 1).Value
Xt = Range(Cells(2, 3), Cells(N + 1, 2 + NumIndpVars)).Value
' set the initial transformations
For i = 1 To TN
CurrentTransf(i) = TransfMat(i, 1)
CountTransf(i) = 1
Next i
fCount = 0
fMilestone = 0.1
Do
On Error GoTo HandleErr
For i = 1 To N
DoEvents
If fCount / fMaxCount > fMilestone Then
DoEvents
Application.StatusBar = "Processed " & CStr(fMilestone * 100) & " %"
If fMilestone < 1 Then fMilestone = fMilestone + 0.05
End If
' sFx = CurrentTransf(1) '[A5].Value
Yt(i, 1) = ExFx(CurrentTransf(1), x, y, i, NumIndpVars)
For J = 1 To NumIndpVars
'sFx = CurrentTransf(J + 1) ' Range("A" & M).Value
Xt(i, J) = ExFx(CurrentTransf(J + 1), x, y, i, NumIndpVars)
Next J
Next i
' perform the regression calculations
vRegResultsMat = Application.WorksheetFunction.LinEst(Yt, Xt, True, True)
Rsqr = vRegResultsMat(3, 1)
F = vRegResultsMat(4, 1)
' check if F > F of last result
If F > Cells(MaxResults + 1, Col3) Then
xval = fCount / fMaxCount * 100
xval = CInt(100 * xval) / 100
Application.StatusBar = "Processed " & CStr(xval) & " %"
M1 = MaxResults + 1
' write new results to row M
Cells(M1, Col3) = F
Cells(M1, Col3 + 1) = Rsqr
For i = 1 To TN
Cells(M1, Col3 + i + 1) = vRegResultsMat(1, TN - i + 1)
Next i
For i = 1 To TN
Cells(M1, Col4 + i) = CurrentTransf(i)
Next i
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5 + 1)).Select
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5 + 1)).Sort Key1:=Range(Cells(2, Col3), Cells(MaxResults + 1, Col3)), Order1:=xlDescending
End If ' If F > Cells(MaxResults + 1, Col3)
GoTo Here
HandleErr:
fCount = fCount - 1
ErrorCounter = ErrorCounter + 1
If ErrorCounter > MaxErrors Then
If MsgBox("Reached maximum error limits of " & ErrorCounter & vbCrLf & _
"Want to stop the process?", vbYesNo + vbQuestion, "Confirmation requested") = vbYes Then
Exit Sub
Else
sMaxErr = InputBox("Update maximum number of errors", "Max Errors Input", MaxErrors)
If Trim(sMaxErr) = "" Then
MsgBox "User canceled calculations process", vbOKOnly + vbInformation, "End of Process"
Exit Sub
End If
MaxErrors = CDbl(sMaxErr)
ErrorCounter = 0
End If
End If
Resume Here
Here:
' ---------------------------------------------------------
' ---------------------------------------------------------
' ------------ Simulate Nested Loops ---------------------
' ---------------------------------------------------------
' ---------------------------------------------------------
For VarIdx = 1 To TN
DoEvents
If CountTransf(VarIdx) >= NumTransf(VarIdx) Then
If VarIdx < TN Then
CurrentTransf(VarIdx) = TransfMat(VarIdx, 1)
CountTransf(VarIdx) = 1
Else
Exit Do
End If
Else
CountTransf(VarIdx) = CountTransf(VarIdx) + 1
CurrentTransf(VarIdx) = TransfMat(VarIdx, CountTransf(VarIdx))
fCount = fCount + 1
Exit For
End If
Next VarIdx
Loop
On Error GoTo 0
dt2 = Now
[a13].Value = "Start"
[a14].Value = dt1
[A15].Value = "End"
[a16].Value = dt2
Application.StatusBar = "Done"
MsgBox "Start at " & CStr(dt1) & vbCrLf & _
"End at " & CStr(dt2), vbOKOnly + vbInformation, "Success!"
Else
myValue = InputBox("How many X Variables are there?", "Number of X Variables", 1)
Range("A2").Value = myValue
answer2 = MsgBox("Do you want to run BestMLR2?", vbYesNo + vbQuestion, _
"Continue BestMLR2 Macro")
If answer2 = vbYes Then
Call BestMLR2
Else
End If
End If
Application.StatusBar = False
End Sub
