ExcelVBA编程实现多元线性回归（vba 拆分excel为多个文件）

这是几个月以前我用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