手动与VBA调用Goal Seek求解Colebrook方程结果不一致的问题排查

我制作了一份用于求解Colebrook方程的电子表格，手动使用Goal Seek工具时效果良好：通过将方程两边的平方差（目标单元格C14）设为0，调整摩擦系数（单元格C11），设置Maximum Change为0.000001，可得到符合需求的摩擦系数。

但编写VBA宏自动化处理不同流量的计算时，VBA调用Goal Seek后，目标单元格无法足够接近0，得到的摩擦系数结果与手动计算不符。已尝试设置Application的MaxIterations和MaxChange参数，问题仍未解决。

宏代码如下：

Sub Darcy()
'
' Darcy Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
Application.ScreenUpdating = False ' Disable screen updating for faster execution
Fila = 2
    Do While Range("G" & Fila) <> ""
    Range("G" & Fila).Select
    Selection.Copy
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C3").Select
    Selection.Copy
    Range("H" & Fila).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Range("C8").Select
    Selection.Copy
    Range("I" & Fila).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("C11").Value = 1
    
    With Application
    .MaxIterations = 100
    .MaxChange = 0.000001
    End With
    Range("C14").GoalSeek Goal:=0, ChangingCell:=Range("C11")
    
    Range("C11").Select
    Selection.Copy
    Range("J" & Fila).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Range("K" & Fila).Value = 1
    
    Fila = Fila + 1
    Loop
End Sub

1. 初始值严重偏离合理范围：代码中每次迭代都将摩擦系数初始值设为1，但实际管道流动的摩擦系数通常在0.01~0.1区间。过大的初始值会让Goal Seek的迭代过程收敛到局部最优解，甚至因非线性方程特性无法逼近正确解。
2. Goal Seek工具局限性：Excel内置的Goal Seek对强非线性方程（如Colebrook方程）稳定性较差，当初始值偏离合理范围时，容易提前终止迭代，达不到手动操作的精度。
3. 全局参数设置的时效性问题：部分Excel版本中，Application的MaxIterations和MaxChange全局设置可能无法立即作用于后续的Goal Seek调用，或者在循环过程中被默认值覆盖。

方法1：优化初始值设置 #

将摩擦系数的初始值改为符合实际范围的数值，替换代码中的Range("C11").Value = 1：

Range("C11").Value = 0.02 ' 替换原初始值1为合理区间的数值

方法2：添加精度校验，重复调用Goal Seek #

如果一次Goal Seek无法达到精度要求，可循环调用直到目标单元格足够接近0：

' 替换原GoalSeek调用部分
With Application
    .MaxIterations = 500 ' 增大迭代次数
    .MaxChange = 1e-8    ' 进一步缩小允许的变化量
End With

' 循环调用直到目标值足够接近0
Do
    Range("C14").GoalSeek Goal:=0, ChangingCell:=Range("C11")
Loop Until Abs(Range("C14").Value) < 1e-6 ' 设定精度阈值

方法3：用牛顿迭代法替代Goal Seek（稳定性更强） #

对于Colebrook这类非线性方程，牛顿迭代法的收敛性和精度更可靠。以下是嵌入宏的实现示例：

' 替换原GoalSeek部分，实现牛顿迭代求解摩擦系数f
Dim f As Double, f_prev As Double, error_val As Double
Dim Re As Double, eps_D As Double 
' 请根据你的表格，替换为实际雷诺数、相对粗糙度所在单元格
Re = Range("Cx").Value 
eps_D = Range("Cy").Value 

f = 0.02 ' 初始值
error_val = 1
Do While error_val > 1e-8 And f > 0.001 ' 防止f过小出现异常
    f_prev = f
    ' Colebrook方程：1/Sqr(f) = -2*Log10( (eps_D/3.7) + (2.51/(Re*Sqr(f))) )
    ' 牛顿迭代公式：f_new = f - f(f)/f'(f)
    Dim f_val As Double, f_deriv As Double
    f_val = 1 / Sqr(f) + 2 * Log10( (eps_D / 3.7) + (2.51 / (Re * Sqr(f))) )
    f_deriv = (-1/(2 * f ^ 1.5)) + 2 * ( (2.51/(2 * Re * f ^ 1.5)) / ( (eps_D/3.7) + (2.51/(Re*Sqr(f))) * Log(10) ) )
    f = f - f_val / f_deriv
    error_val = Abs(f - f_prev)
Loop
Range("C11").Value = f ' 将求解结果写入目标单元格

额外优化：移除冗余的Select操作 #

原代码大量使用Select和Selection，效率低且易出错，可直接通过单元格赋值替代：

' 替换原复制粘贴部分
Range("C1").Value = Range("G" & Fila).Value
Range("H" & Fila).Value = Range("C3").Value
Range("I" & Fila).Value = Range("C8").Value
' 后续复制粘贴操作同理修改

内容的提问来源于stack exchange，提问作者user20056581