这是一个简单的可直接在Excel中使用的VBA脚本。用于指数形式的回归：Y=aX^b。这种形式本质上是线性回归。需要注意的是，此代码要求X和Y均为正值，否则请先做必要的变换。
‘Author: zhb (zhanghongbo@itpcas.ac.cn)
‘Date: 2015.7.21
‘Final Revision: 2015.7.22
Option Explicit
Private Sub CommandButton1_Click()
Dim xx As Range
Dim yy As Range
Dim aa As Range
Dim bb As Range
Dim tt As Range
Dim pp As Range
Dim ss As Range
Dim rr As Range
Dim nn As Range
With ActiveSheet
Set xx = .Range(“X”)
Set yy = .Range(“Y”)
Set aa = .Range(“E_a”)
Set bb = .Range(“E_b”)
Set tt = .Range(“Times”)
Set pp = .Range(“Percentage”)
Set ss = .Range(“Selected_Samples”)
Set rr = .Range(“MY_R2″)
Set nn = .Range(“NSE”)
End With
Dim n As Integer
n = 0
Dim xi As String
Dim ir, ic As Integer
ir = 1
ic = 0
Do While True
If xx.Cells(ir, 1) = “” Or yy.Cells(ir, 1) = “” Then
ir = ir – 1
Exit Do
End If
ir = ir + 1
Loop
n = ir
‘MsgBox “n: ” & ir
Dim perc As Single
Dim nt As Integer
perc = pp.Cells(1, 1) / 100#
nt = tt.Cells(1, 1)
Dim ns As Integer
ns = perc * n
Dim tinds() As Integer
ReDim tinds(1 To n)
Dim newi() As Integer
ReDim newi(1 To ns)
Dim sx(), sy() As Double
ReDim sx(1 To ns)
ReDim sy(1 To ns)
Dim sx0(), sy0() As Double
ReDim sx0(1 To ns)
ReDim sy0(1 To ns)
Dim y1(), r2, nse As Double
ReDim y1(1 To ns)
Dim SSE, SSA As Double
‘nt = 2
Dim i, j, k, m, tmp As Integer
Dim r As Variant
Dim a, b As Double
For i = 1 To nt
For j = 1 To n
tinds(j) = j
Next j
For j = 1 To ns
m = Int(Rnd() * (n – j)) + 1
tmp = tinds(j)
tinds(j) = tinds(j + m – 1)
tinds(j + m – 1) = tmp
Next j
For j = 1 To ns
newi(j) = tinds(j)
ss.Cells(j, (i – 1) * 2 + 1) = xx.Cells(newi(j), 1)
ss.Cells(j, (i – 1) * 2 + 2) = yy.Cells(newi(j), 1)
sx0(j) = xx.Cells(newi(j), 1)
sy0(j) = xx.Cells(newi(j), 2)
Next j
For j = 1 To ns
sx(j) = Log(sx0(j))
sy(j) = Log(sy0(j))
Next j
a = WorksheetFunction.Intercept(sy, sx)
b = WorksheetFunction.Slope(sy, sx)
a = Exp(a)
SSE = 0
SSA = 0
m = WorksheetFunction.Average(sy0)
For j = 1 To ns
y1(j) = a * (sx0(j) ^ b)
SSE = SSE + (y1(j) – sy0(j)) ^ 2
SSA = SSA + (sy0(j) – m) ^ 2
Next j
r2 = WorksheetFunction.RSq(sy0, y1)
nse = 1 – (SSE / SSA)
aa.Cells(i, 1) = a
bb.Cells(i, 1) = b
rr.Cells(i, 1) = r2
nn.Cells(i, 1) = nse
Next i
MsgBox “完成！”, vbOKOnly, “提示”
End Sub