Help correcting macro

M

michaelsmith559

Well-known Member
Joined
Oct 6, 2013
Messages
881
Office Version
  1. 2013
  2. 2007
I need help correcting a macro. Below will be 3 macros. The macro called "bestmlr2" is the one I am trying to duplicate. The macro "bestmlr2" allows me to enter variable transformations as expressions and evaluates them for linear regression models. It works great. The macro called "originalbestpolyreg" is the macro for the original polynomial regression. The difference is that you cannot enter expressions like in "bestmlr2". The macro "bestpoly1" is my attempt at modifying "originalbestpolyreg" to use expressions. I pretty much copied elements from "bestmlr2". However, it is giving an error saying "next without for" for the line "Here: iX" I cannot figure out why. It looks as all loops have been closed, but I cannot find where I missed it. Here are the codes. Thanks for any help.

Code: 
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, WS As Worksheet, newws As Worksheet
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, mresults As Variant
Dim yrng As Range, xrng As Range, xcount As Long, a As Long
Dim lastc As Long, Ty As Range, Tx As Range, xpaste As Long
Set yrng = Application.InputBox(prompt:="Select Y Range", Type:=8)
Set xrng = Application.InputBox(prompt:="Select X Range", Type:=8)
Set WS = Workbooks("Multiple Linear Regression using Transformations.xlam").Sheets("Variable Transformations")
Set Ty = WS.Range(WS.Range("A2"), WS.Range("A2").End(xlDown))
Set Tx = WS.Range(WS.Range("B2"), WS.Range("B2").End(xlDown))
xcount = xrng.Columns.Count
mresults = InputBox("Maximum Results to Display")
On Error Resume Next
Set WS = Sheets("MLR1")
If Err.Number <> 0 Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MLR1"
Else
End If
Sheets("MLR1").Activate
    With Sheets("MLR1")
        .Cells.ClearContents
        .Cells(1, 1).Value = "Number of X Variables"
        .Cells(2, 1).Value = xcount
        .Cells(3, 1).Value = "Max Results"
        .Cells(4, 1).Value = mresults
        .Cells(1, 2).Value = "Y"
        .Cells(2, 2).Resize(yrng.Rows.Count, yrng.Columns.Count).Cells.Value = _
            yrng.Cells.Value
            For a = 1 To xcount
                Cells(1, a + 2).Value = "X" & a
            Next a
        .Cells(2, 3).Resize(xrng.Rows.Count, xrng.Columns.Count).Cells.Value = _
            xrng.Cells.Value
    End With
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, lastc + 2).Value = "Transform Y"
Cells(2, lastc + 2).Resize(Ty.Rows.Count, Ty.Columns.Count).Cells.Value = _
            Ty.Cells.Value
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
    For a = 1 To xcount
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
        Cells(1, lastc + 1).Value = "Transform " & "X" & a
    Next a
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(2, lastc - xcount + 1).Resize(Tx.Rows.Count, Tx.Columns.Count).Cells.Value = _
    Tx.Cells.Value
xpaste = 1
    For a = xpaste To xcount - 1
        Range(Cells(2, lastc - xcount + a), Cells(Rows.Count, lastc - xcount + a).End(xlUp)).Select
        Selection.Copy Selection.Offset(0, 1)
        Selection.Offset(0, 1).Select
        Selection.Replace "X" & a, "X" & a + 1, xlPart
    Next a
Cells(1, lastc + 2).Value = "F"
Cells(1, lastc + 3).Value = "Rsq"
Cells(1, lastc + 4).Value = "Intercept"
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
    For a = 1 To xcount
        Cells(1, lastc + a).Value = "Slope" & a
    Next a
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, lastc + 1).Value = "Transform " & "Y"
    For a = 1 To xcount
        Cells(1, lastc + a + 1).Value = "Transform" & "X" & a
    Next a
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
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
[A6].Value = "Start"
[A7].Value = dt1
[A8].Value = "End"
[A9].Value = dt2
Range(Cells(1, 1), Cells(Rows.Count, lastc).End(xlUp)).EntireColumn.AutoFit
Range(Cells(1, 1), Cells(Rows.Count, lastc).End(xlUp)).HorizontalAlignment = xlCenter
Application.StatusBar = "Done"
MsgBox "Start at " & CStr(dt1) & vbCrLf & _
"End at " & CStr(dt2), vbOKOnly + vbInformation, "Success!"
End Sub

Code: 
Option Explicit
Option Base 1
Sub OriginalBestPolyReg()
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 variables
Dim PolyOrder As Integer ' polynomial order
Dim TN As Integer ' total number coefficients
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 iY As Integer, iX As Integer
Dim TransfMat() As Double
Dim CurrentTransf() As Double, 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 Xtp() As Variant
Dim vRegResultsMat As Variant
Dim F As Double, Rsqr As Double, xval As Double
Dim ShiftX As Double, ShiftY As Double
Dim ScaleX As Double, ScaleY As Double
ErrorCounter = 0
MaxErrors = MAX_ERRORS
NumIndpVars = 2
PolyOrder = [A2].Value
MaxResults = [A4].Value
TN = PolyOrder + 1
ShiftX = [A6].Value
ScaleX = [A8].Value
ShiftY = [A10].Value
ScaleY = [A12].Value
Col1 = 2  ' first column of data
Col2 = 5  ' first column of transformations
Col3 = 8  ' first column of best transformations
Col4 = 10 ' first column of results
Col5 = Col4 + TN + 1  ' last column of results
Range(Cells(1 + Col3), Cells(1, 50)).Value = ""
Cells(1, Col3) = "Transf Y"
Cells(1, Col3 + 1) = "Transf X"
Cells(1, Col4) = "F"
Cells(1, Col4 + 1) = "Rsqr"
For I = 0 To PolyOrder
Cells(1, Col4 + 2 + I) = "A" & I
Next I
Range(Cells(2, Col3), Cells(1 + 2 * MaxResults, Col4 + 3 * TN)).Value = ""
Range(Cells(2, Col4), Cells(1 + MaxResults, Col4 + 1 + TN)).Value = 0
MaxTrans = Range(Cells(2, Col2), Cells(1, Col2)).CurrentRegion.Rows.Count - 1
ReDim NumTransf(NumIndpVars), TransfMat(NumIndpVars, MaxTrans), CurrentTransf(NumIndpVars)
ReDim CountTransf(NumIndpVars)
For I = 1 To NumIndpVars
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
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 + PolyOrder)).Value
Yt = Range("B2:B" & N + 1).Value
Xt = Range(Cells(2, 3), Cells(N + 1, 2 + PolyOrder)).Value
ReDim Xtp(N, PolyOrder) ' polynomial data matrix
For iY = 1 To NumTransf(1)
CurrentTransf(1) = TransfMat(1, iY)
For iX = 1 To NumTransf(2)
CurrentTransf(2) = TransfMat(2, iX)
On Error GoTo HandleErr
For I = 1 To N
DoEvents
If CurrentTransf(1) <> 0 Then
Yt(I, 1) = (ScaleY * Y(I, 1) + ShiftY) ^ CurrentTransf(1)
Else
Yt(I, 1) = Log(ScaleY * Y(I, 1) + ShiftY)
End If
If CurrentTransf(2) <> 0 Then
Xt(I, 1) = (ScaleX * X(I, 1) + ShiftX) ^ CurrentTransf(2)
Else
Xt(I, 1) = Log(ScaleX * X(I, 1) + ShiftX)
End If
For J = 1 To PolyOrder
Xtp(I, J) = Xt(I, 1) ^ J
Next J
Next I
' perform the regression calculations
vRegResultsMat = Application.WorksheetFunction.LinEst(Yt, Xtp, True, True)
Rsqr = vRegResultsMat(3, 1)
F = vRegResultsMat(4, 1)
' check if F > F of last result
If F > Cells(MaxResults + 1, Col4) Then
M1 = MaxResults + 1
' write new results to row M
Cells(M1, Col4) = F
Cells(M1, Col4 + 1) = Rsqr
For I = 1 To TN
Cells(M1, Col4 + I + 1) = vRegResultsMat(1, TN - I + 1)
Next I
For I = 1 To NumIndpVars
Cells(M1, Col3 + I - 1) = CurrentTransf(I)
Next I
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5)).Select
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5)).Sort _
    Key1:=Range(Cells(2, Col4), Cells(MaxResults + 1, Col4)), Order1:=xlDescending
End If ' If F > Cells(MaxResults + 1, Col3)
GoTo Here
HandleErr:
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", "MaxErrors 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:
Next iX
Next iY
MsgBox "Done", vbOKOnly + vbInformation, "Success!"
End Sub

Code: 
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 BestPoly1()
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 PolyOrder As Integer
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, Xtp() As Variant
Dim iY As Integer, iX As Integer
Dim vRegResultsMat As Variant, WS As Worksheet, newws As Worksheet
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, mresults As Variant
Dim ShiftX As Double, ShiftY As Double, ScaleX As Double, ScaleY As Double
Dim yrng As Range, xrng As Range, xcount As Long, a As Long
Dim lastc As Long, Ty As Range, Tx As Range, xpaste As Long
Dim porder As Long
Set yrng = Application.InputBox(prompt:="Select Y Range", Type:=8)
Set xrng = Application.InputBox(prompt:="Select X Range", Type:=8)
porder = InputBox("Input Poly Order")
Set WS = Workbooks("Multiple Linear Regression using Transformations.xlam").Sheets("Variable Transformations")
Set Ty = WS.Range(WS.Range("A2"), WS.Range("A2").End(xlDown))
Set Tx = WS.Range(WS.Range("B2"), WS.Range("B2").End(xlDown))
xcount = xrng.Columns.Count
mresults = InputBox("Maximum Results to Display")
On Error Resume Next
Set WS = Sheets("Poly1")
If Err.Number <> 0 Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Poly1"
Else
End If
Sheets("Poly1").Activate
    With Sheets("Poly1")
        .Cells.ClearContents
        .Cells(1, 1).Value = "Polynomial Order"
        .Cells(2, 1).Value = porder
        .Cells(3, 1).Value = "Max Results"
        .Cells(4, 1).Value = mresults
        .Cells(5, 1).Value = "Shift X"
        .Cells(6, 1).Value = InputBox("Shift X Value")
        .Cells(7, 1).Value = "Scale X"
        .Cells(8, 1).Value = InputBox("Scale X Value")
        .Cells(9, 1).Value = "Shift Y"
        .Cells(10, 1).Value = InputBox("Shift Y Value")
        .Cells(11, 1).Value = "Scale Y"
        .Cells(12, 1).Value = InputBox("Scale Y Value")
        .Cells(1, 2).Value = "Y"
        .Cells(2, 2).Resize(yrng.Rows.Count, yrng.Columns.Count).Cells.Value = _
            yrng.Cells.Value
            For a = 1 To xcount
                Cells(1, a + 2).Value = "X" & a
            Next a
        .Cells(2, 3).Resize(xrng.Rows.Count, xrng.Columns.Count).Cells.Value = _
            xrng.Cells.Value
    End With
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, lastc + 2).Value = "Transform Y"
Cells(2, lastc + 2).Resize(Ty.Rows.Count, Ty.Columns.Count).Cells.Value = _
            Ty.Cells.Value
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
    For a = 1 To xcount
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
        Cells(1, lastc + 1).Value = "Transform " & "X" & a
    Next a
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(2, lastc - xcount + 1).Resize(Tx.Rows.Count, Tx.Columns.Count).Cells.Value = _
    Tx.Cells.Value
xpaste = 1
    For a = xpaste To xcount - 1
        Range(Cells(2, lastc - xcount + a), Cells(Rows.Count, lastc - xcount + a).End(xlUp)).Select
        Selection.Copy Selection.Offset(0, 1)
        Selection.Offset(0, 1).Select
        Selection.Replace "X" & a, "X" & a + 1, xlPart
    Next a
dt1 = Now
ErrorCounter = 0
MaxErrors = MAX_ERRORS
NumIndpVars = 2
PolyOrder = [A2].Value
MaxResults = [A4].Value
TN = PolyOrder + 1
ShiftX = [A6].Value
ScaleX = [A8].Value
ShiftY = [A10].Value
ScaleY = [A12].Value
Col1 = 2 ' first column of data
Col2 = 5 ' first column of transformations
Col3 = 8 ' first column of results
Col4 = 10 ' first column of tranformatioons
Col5 = Col4 + TN + 1 ' last column of transformations
Range(Cells(1 + Col3), Cells(1, 50)).Value = ""
Cells(1, Col3) = "Transform Y"
Cells(1, Col3 + 1) = "Transform X"
Cells(1, Col4) = "F"
Cells(1, Col4 + 1) = "Rsqr"
    For I = 0 To PolyOrder
        Cells(1, Col4 + 2 + I) = "A" & I
    Next I
Range(Cells(2, Col3), Cells(1 + 2 * MaxResults, Col4 + 3 * TN)).Value = ""
Range(Cells(2, Col4), Cells(1 + MaxResults, Col4 + 1 * TN)).Value = 0
MaxTrans = Range(Cells(2, Col2), Cells(1, Col2)).CurrentRegion.Rows.Count - 1
ReDim NumTransf(NumIndpVars), TransfMat(NumIndpVars, MaxTrans), CurrentTransf(NumIndpVars)
ReDim CountTransf(NumIndpVars)
fMaxCount = 1
For I = 1 To NumIndpVars
    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 + PolyOrder)).Value
Yt = Range("B2:B" & N + 1).Value
Xt = Range(Cells(2, 3), Cells(N + 1, 2 + PolyOrder)).Value
ReDim Xtp(N, PolyOrder) 'polynomial data matrix
For iY = 1 To NumTransf(1)
    CurrentTransf(1) = TransfMat(1, iY)
For iX = 1 To NumTransf(2)
    CurrentTransf(2) = TransfMat(2, iX)
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
If CurrentTransf(1) <> 0 Then
    Yt(I, 1) = (ScaleY * Y(I, 1) + ShiftY) ^ CurrentTransf(1)
Else
    Yt(I, 1) = Log(ScaleY * Y(I, 1) + ShiftY)
End If
    
If CurrentTransf(2) <> 0 Then
    Xt(I, 1) = (ScaleX * X(I, 1) + ShiftX) ^ CurrentTransf(2)
Else
    Xt(I, 1) = Log(ScaleX * X(I, 1) + ShiftX)
End If
    
For J = 1 To PolyOrder
    Xtp(I, J) = ExFx(CurrentTransf(I + 1), X, Y, I, NumIndpVars) ^ J
Next J
Next I
' perform the regression calculations
vRegResultsMat = Application.WorksheetFunction.LinEst(Yt, Xtp, True, True)
Rsqr = vRegResultsMat(3, 1)
F = vRegResultsMat(4, 1)
' check if F > F of last result
If F > Cells(MaxResults + 1, Col4) 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, Col4) = F
Cells(M1, Col4 + 1) = Rsqr
For I = 1 To TN
    Cells(M1, Col4 + I + 1) = vRegResultsMat(1, TN - I + 1)
Next I
For I = 1 To NumIndpVars
    Cells(M1, Col3 + I - 1) = CurrentTransf(I)
Next I
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5)).Select
Range(Cells(2, Col3), Cells(MaxResults + 1, Col5)).Sort Key1:=Range(Cells(2, Col4), Cells(MaxResults + 1, Col4)), 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:
    Next iX
Next iY
' ---------------------------------------------------------
' ---------------------------------------------------------
' ------------ Simulate Nested Loops ---------------------
' ---------------------------------------------------------
' ---------------------------------------------------------
For VarIdx = 1 To TN
    
If CountTransf(VarIdx) >= NumTransf(VarIdx) Then
    If VarIdx < TN Then
        CurrentTransf(VarIdx) = TransfMat(VarIdx, 1)
        CountTransf(VarIdx) = 1
    Else
        
    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
[A6].Value = "Start"
[A7].Value = dt1
[A8].Value = "End"
[A9].Value = dt2
Range(Cells(1, 1), Cells(Rows.Count, lastc).End(xlUp)).EntireColumn.AutoFit
Range(Cells(1, 1), Cells(Rows.Count, lastc).End(xlUp)).HorizontalAlignment = xlCenter
MsgBox "Start at " & CStr(dt1) & vbCrLf & _
"End at " & CStr(dt2), vbOKOnly + vbInformation, "Success!"
End Sub
 
Sort by date Sort by votes
shg,

How would you perform the following using either algebra or linest:

Given:

Excel 2007
ABCD
1Transform YTransformX1TransformX2TransformX3
2LN(Y)^TAN(Y)EXP(X1)LN(X2)^SIN(X2)LN(X3)^TAN(X3)
3InterceptSlope1Slope2Slope3
4-2.81475E+142.3148E-1371.62161E+130.999957481
5
6YX1X2X3
7340.9783721340.9886097340.9783733340.9783721
8
9Find Y using the transforms:
10-8.00627E+25
Sheet1
Cell Formulas
RangeFormula
A10=$A$4*($B$4*EXP(B7))+($C$4*(LN(C7)^SIN(C7)))+($D$4*(LN(D7)^TAN(D7)))


The value in A10 is suppose to be substituted back into the equation in A2.
You would then perform inverse operations to convert the y transform back to the value in A7.

For example if A2 contained: Y^3, you would do this Y^(1/3) to convert it;
If A2 contained LN(Y) you would do EXP(Y), etc. I am not sure how to convert back to y given
the formula in A2 for the above. How would you do this algebraically and using linest? Thanks for the
help.

Mike
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
=linest(ln(y)^tan(y), choose({1,2,3}, exp(xxx1), ln(xxx2)^sin(xxx2), ln(xxx3)^tan(xxx3)))
 
Last edited:
Upvote 0
Hey, just tried your formula and I could not get it to work correctly.

Here is what I did also shown in some more data.


Excel 2007
ABCD
1Transform YTransformX1TransformX2TransformX3
2LN(Y)^TAN(Y)EXP(X1)LN(X2)^SIN(X2)LN(X3)^TAN(X3)
3InterceptSlope1Slope2Slope3
4-2.81E+142.31E-1371.62E+130.999957481
5
6YX1X2X3
7340.9783721340.9886097340.9783733340.9783721
8
9Find Y using the transforms:
10-8.00617E+25This value needs to be converted back to A7
11doing the opposite of the formula in A2
12
13YX1X2X3
14340.9783721340.9886097340.9783733340.9783721
15341.9787243341.9860619341.9787255341.9787244
16342.9790754342.9835129342.9790765342.9790754
17343.9794253343.9791604344.9797776343.9794253
18344.9797742344.9793128344.4796003344.9797741
19345.9801218345.9758592345.980123345.9801218
20346.9804684346.9733058346.9804695346.9804684
21347.9808138347.9707512347.9808149347.9808139
22
23m3m2m1b
240.99995748-1.05348E+131.1574E-1370
25
26Prediction using Linest
27-3.59213E+15
Sheet1
Cell Formulas
RangeFormula
A10=$A$4*($B$4*EXP(B7))+($C$4*(LN(C7)^SIN(C7)))+($D$4*(LN(D7)^TAN(D7)))
A27=$D$24+$C$24*B14+$B$24*C14+$A$24*D14
A24:D24{=LINEST(LN(A14:A21)^TAN(A14:A21), CHOOSE({1,2,3}, EXP(B14:B21), LN(C14:C21)^SIN(C14:C21), LN(D14:D21)^TAN(D14:D21)))}
Press CTRL+SHIFT+ENTER to enter array formulas.
 
Upvote 0
Is this a made-up problem? What kind of regression has coefficients spanning 150 orders of magnitude?
 
Upvote 0
Yes the problem is made up, with the goal of just trying different transforms. In post #1, when the x variables are transformed by using the transform equation, it gives a transformed predicted value of y contained in A10. That value is now in the form of A2. You are suppose to be able to do opposite operations to convert the transformed y value back to normal Y in the form of A7. I am unable to convert the value from the transform results back. My assumption was first to transform the value in A10 back by using EXP(A10)^ATAN(A10) or EXP(A10)^(1/(ATAN(A10)). Neither works. Because it uses trig functions, I am assuming this will not be a straight forward conversion back to standard form. I am unsure if degrees, radians, pi, etc have to be used to get the value in A10 back to the form in A7. I was hoping after you suggested using linest with the x transforms, it would give me the standard form of Y and not the transformed y. This is a made up data set, but the point remains the same of converting the value back to standard Y vs. transformed y.
 
Upvote 0
Have you plotted ln(y)^tan(y)? Its inverse is not bijective, so there is no 'back transformation.'

Similarly, you might plot ln(X)^sin(X) and ponder its appropriateness as a basis function.

You said this was for fun, so ... have fun.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA Code- finding #Spill and moving the formula to the next column
Replies
0
Views
419
stromnoexcel
S
Guna13
  • Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
759
Guna13
Guna13
M
  • Question
I need help with this code to modify the data into a table using Userform for VBA Excel (I want to do the range unlimited instead to do C7:C80000
Replies
5
Views
471
Dan_W
D
P
  • Question
Freeze on specific sheet during macro execution and loop through each sheets containing a specific name
Replies
5
Views
720
BSALV
BSALV
E
  • Question
FIFO Macro giving different results each time it runs
Replies
7
Views
817
Lee Wei Sin
L

Forum statistics

Threads
1,215,140
Messages
6,123,269
Members
449,093
Latest member
Vincent Khandagale

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top