这是几个月以前我用Excel VBA进行的几个编程练习，涉及到字符串处理，计算，用户界面控制，以及基本的统计学知识。主要是3个案例，1是多元线性回归，人输入公式，要Excel自动读取并回归出权重值；2是蒙特卡洛模拟，给定几个指标的概率分布，让Excel自动测算任意次运行结果；3是美国城市距离测算，重点在搜索算法应用，以及VBA从网页爬取信息（但是爬虫还是Python方便啊真的哈哈）。
不说废话，这篇文章讲第一个案例，Excel中怎么识别任意种回归公式？
其实类似于操作Eviews时在控制行输入公式的做法。
目标：
首先是这样的用户页面
约定：A列x值，B列y值，VBA将根据位置读取数据；给出f1-f4四项，可以输入任意符合“与x相关的数学表达”规则的公式，例如图中给出了平方，分数，对数运算，加减更不在话下。
编程重点：首先页面实现，打开开发工具创建即可，其次公式识别，字符串处理，最后权重回归，弹窗返回。同时要有拖动滑块选定任意行数据的功能。
D到G列输出各项值并弹窗返回回归结果
同时VBA应计算出这次回归的统计指标，例如R值，并且将回归曲线作图返回。R值在作图之前弹窗提示。
回归线作图
代码：
Option Explicit
Option Base 1
Private Sub GoButton_Click()
Dim tWB As Workbook, ypre As String
Dim UserXRange As Range, UserYRange As Range
Dim i As Integer, j As Integer, Ans As Integer, addx As String, addy As String, numx As Integer, numy As Integer
Dim x As Variant, y As Variant, nterm As Integer, xtx As Variant, xtxi, xty As Variant, xt As Variant
ActiveWorkbook.Sheets(1).Range("C1:G20").Clear
Set tWB = ThisWorkbook
tWB.Activate
nterm = 0
If UserForm1.fxn1.Text <> "" Then
nterm = nterm 1
If Not InStr(UserForm1.fxn1.Text, "x") > 0 Then
MsgBox "Input expression with x."
Unload UserForm1
UserForm1.Show
End If
End If
If UserForm1.fxn2.Text <> "" Then
nterm = nterm 1
If Not InStr(UserForm1.fxn1.Text, "x") > 0 Then
MsgBox "Input expression with x."
Unload UserForm1
UserForm1.Show
End If
End If
If UserForm1.fxn3.Text <> "" Then
nterm = nterm 1
If Not InStr(UserForm1.fxn1.Text, "x") > 0 Then
MsgBox "Input expression with x."
Unload UserForm1
UserForm1.Show
End If
End If
If UserForm1.fxn4.Text <> "" Then
nterm = nterm 1
If Not InStr(UserForm1.fxn1.Text, "x") > 0 Then
MsgBox "Input expression with x."
Unload UserForm1
UserForm1.Show
End If
End If
Set UserXRange = Application.InputBox("X Input Range", "X Input", "Sheet1!$A$1:$A$10", Type:=8)
Set UserYRange = Application.InputBox("Y Input Range", "Y Input", "Sheet1!$B$1:$B$10", Type:=8)
numx = UserXRange.Rows.Count
numy = UserYRange.Rows.Count
If nterm = 0 Then
MsgBox "You must input at least one term of X"
Exit Sub
End If
If numx <> numy Then
MsgBox "The number of X data and Y data is not equal, reset."
Exit Sub
End If
If numx < nterm 2 Then
MsgBox "You must input more X-Y data (At least Number of Function 2)."
Exit Sub
End If
addx = UserXRange.Address
addy = UserYRange.Address
ActiveWorkbook.Names.add Name:="x", RefersToR1C1:=ActiveWorkbook.Sheets(1).Range(addx)
ActiveWorkbook.Names.add Name:="Y", RefersToR1C1:=ActiveWorkbook.Sheets(1).Range(addy)
Dim beta As Variant, yp As Variant
ReDim beta(nterm 1, 1) As Variant, yp(numx, 1) As Variant
If nterm = 1 Then
ReDim x(numx, 2) As Variant, y(numx, 1) As Variant
For i = 1 To numx
x(i, 1) = 1
If UserForm1.fxn1.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
End If
If UserForm1.fxn2.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
End If
If UserForm1.fxn3.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
End If
If UserForm1.fxn4.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
x(i, 2) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value
y(i, 1) = ActiveWorkbook.Sheets(1).Range(addy).Cells(i, 1)
Next i
xt = Application.WorksheetFunction.Transpose(x)
xtx = Application.WorksheetFunction.MMult(xt, x)
xty = Application.WorksheetFunction.MMult(xt, y)
xtxi = Application.WorksheetFunction.MInverse(xtx)
beta = Application.WorksheetFunction.MMult(xtxi, xty)
yp = Application.WorksheetFunction.MMult(x, beta)
For i = 1 To numx
ActiveWorkbook.Sheets(1).Cells(i, 3).Value = yp(i, 1)
Next i
End If
If nterm = 2 Then
ReDim x(numx, 3) As Variant, y(numx, 1) As Variant
For i = 1 To numx
x(i, 1) = 1
If UserForm1.fxn1.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
If UserForm1.fxn2.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
End If
If UserForm1.fxn3.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
End If
If UserForm1.fxn4.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
End If
If UserForm1.fxn2.Text <> "" And UserForm1.fxn3.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
End If
If UserForm1.fxn4.Text <> "" And UserForm1.fxn2.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
End If
If UserForm1.fxn3.Text <> "" And UserForm1.fxn4.Text <> "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
x(i, 2) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value
x(i, 3) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value
y(i, 1) = ActiveWorkbook.Sheets(1).Range(addy).Cells(i, 1)
Next i
xt = Application.WorksheetFunction.Transpose(x)
xtx = Application.WorksheetFunction.MMult(xt, x)
xty = Application.WorksheetFunction.MMult(xt, y)
xtxi = Application.WorksheetFunction.MInverse(xtx)
beta = Application.WorksheetFunction.MMult(xtxi, xty)
yp = Application.WorksheetFunction.MMult(x, beta)
For i = 1 To numx
ActiveWorkbook.Sheets(1).Cells(i, 3).Value = yp(i, 1)
Next i
End If
If nterm = 3 Then
ReDim x(numx, 4) As Variant, y(numx, 1) As Variant
For i = 1 To numx
x(i, 1) = 1
If UserForm1.fxn1.Text = "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
If UserForm1.fxn2.Text = "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
If UserForm1.fxn3.Text = "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
End If
If UserForm1.fxn4.Text = "" Then
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
End If
x(i, 2) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value
x(i, 3) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value
x(i, 4) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value
y(i, 1) = ActiveWorkbook.Sheets(1).Range(addy).Cells(i, 1)
Next i
xt = Application.WorksheetFunction.Transpose(x)
xtx = Application.WorksheetFunction.MMult(xt, x)
xty = Application.WorksheetFunction.MMult(xt, y)
xtxi = Application.WorksheetFunction.MInverse(xtx)
beta = Application.WorksheetFunction.MMult(xtxi, xty)
yp = Application.WorksheetFunction.MMult(x, beta)
For i = 1 To numx
ActiveWorkbook.Sheets(1).Cells(i, 3).Value = yp(i, 1)
Next i
End If
If nterm = 4 Then
ReDim x(numx, 5) As Variant, y(numx, 1) As Variant
For i = 1 To numx
x(i, 1) = 1
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn1.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn2.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn3.Text))(i)
ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 6).Value = Application.WorksheetFunction.Transpose(Evaluate("=" & UserForm1.fxn4.Text))(i)
x(i, 2) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 3).Value
x(i, 3) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 4).Value
x(i, 4) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 5).Value
x(i, 5) = ActiveWorkbook.Sheets(1).Range(addx).Cells(i, 1).Offset(0, 6).Value
y(i, 1) = ActiveWorkbook.Sheets(1).Range(addy).Cells(i, 1)
Next i
xt = Application.WorksheetFunction.Transpose(x)
xtx = Application.WorksheetFunction.MMult(xt, x)
xty = Application.WorksheetFunction.MMult(xt, y)
xtxi = Application.WorksheetFunction.MInverse(xtx)
beta = Application.WorksheetFunction.MMult(xtxi, xty)
yp = Application.WorksheetFunction.MMult(x, beta)
For i = 1 To numx
ActiveWorkbook.Sheets(1).Cells(i, 3).Value = yp(i, 1)
Next i
End If
ypre = ActiveWorkbook.Sheets(1).Range("C1:C" & numx).Address
If nterm = 1 Then
If UserForm1.fxn1.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text)
End If
If UserForm1.fxn2.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn2.Text)
End If
If UserForm1.fxn3.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn3.Text)
End If
If UserForm1.fxn4.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn4.Text)
End If
End If
If nterm = 2 Then
If UserForm1.fxn1.Text <> "" Then
If UserForm1.fxn2.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn2.Text)
End If
If UserForm1.fxn3.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn3.Text)
End If
If UserForm1.fxn4.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn4.Text)
End If
End If
If UserForm1.fxn2.Text <> "" And UserForm1.fxn3.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn2.Text & " " & beta(3, 1) & "*" & UserForm1.fxn3.Text)
End If
If UserForm1.fxn4.Text <> "" And UserForm1.fxn2.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn2.Text & " " & beta(3, 1) & "*" & UserForm1.fxn4.Text)
End If
If UserForm1.fxn3.Text <> "" And UserForm1.fxn4.Text <> "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn3.Text & " " & beta(3, 1) & "*" & UserForm1.fxn4.Text)
End If
End If
If nterm = 3 Then
If UserForm1.fxn1.Text = "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn2.Text & " " & beta(3, 1) & "*" & UserForm1.fxn3.Text & " " & beta(4, 1) & "*" & UserForm1.fxn4.Text)
End If
If UserForm1.fxn2.Text = "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn3.Text & " " & beta(4, 1) & "*" & UserForm1.fxn4.Text)
End If
If UserForm1.fxn3.Text = "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn2.Text & " " & beta(4, 1) & "*" & UserForm1.fxn4.Text)
End If
If UserForm1.fxn4.Text = "" Then
MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn2.Text & " " & beta(4, 1) & "*" & UserForm1.fxn3.Text)
End If
End If
If nterm = 4 Then MsgBox ("The Regression Result: Predictive y = " & beta(1, 1) & " " & beta(2, 1) & "*" & UserForm1.fxn1.Text & " " & beta(3, 1) & "*" & UserForm1.fxn2.Text & " " & beta(4, 1) & "*" & UserForm1.fxn3.Text & " " & beta(5, 1) & "*" & UserForm1.fxn4.Text)
Dim sse As Double, sst As Double, ar2 As Double, yave As Double
sse = 0
sst = 0
yave = Application.WorksheetFunction.Average(Range(addy))
For i = 1 To numx
sse = sse (Range("B" & i) - Range("C" & i)) * (Range("B" & i) - Range("C" & i))
sst = sst (Range("B" & i) - yave) * (Range("B" & i) - yave)
Next i
ar2 = 1 - (sse / (numx - nterm - 1)) / (sst / (numx - 1))
MsgBox ("The adjusted R-squared is " & Format(Str(ar2), "0.0000"))
Ans = MsgBox("Would you like to plot the data?", vbYesNo)
If Ans = 6 Then
Call Plotting(addx, addy, ypre)
End If
End Sub
Private Sub QuitButton_Click()
Unload UserForm1
End Sub
Sub Plotting(xdata As String, ydata As String, yp As String)
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
ActiveChart.SetSourceData Source:=Union(Range(xdata), Range(ydata), Range(yp))
ActiveChart.ChartTitle.Select
Selection.Delete
ActiveChart.PlotArea.Select
Application.CutCopyMode = False
ActiveChart.FullSeriesCollection(1).Name = "=""Experimental Data"""
ActiveChart.FullSeriesCollection(2).Name = "=""Predictive Y"""
ActiveChart.FullSeriesCollection(2).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent4
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
End With
Selection.MarkerStyle = -4142
ActiveChart.SetElement (msoElementLegendRight)
ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleAdjacentToAxis)
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Characters.Text = "X"
With Selection.Format.TextFrame2.TextRange.Characters(1, 1).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 1).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = " mn-cs"
.NameFarEast = " mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = " mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 1).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 1).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = " mn-cs"
.NameFarEast = " mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Italic = msoFalse
.Kerning = 12
.Name = " mn-lt"
.UnderlineStyle = msoNoUnderline
.Strike = msoNoStrike
End With
Selection.Orientation = xlVertical
Selection.Orientation = xlHorizontal
Application.CommandBars("Format Object").Visible = False
End Sub,
