三角棱锥偏移3D平面交点VBA Solver求解异常修复咨询

• 目标函数定义错误：当前代码中my1/my2/my3的结尾分别减去x/y/z坐标，实际应该减去对应偏移距离r1/r2/r3，和坐标本身无关联。
• GRG非线性求解器易陷入局部最优：未给求解器设置合理的初始猜测值，默认从0开始迭代，很容易陷入离初始值近的局部极小值（第6行结果停在0,0,0就是该原因导致）。
• 法向量方向未统一：用Abs计算点到平面距离虽然能得到绝对值，但无法保证平面偏移方向朝向棱锥内部，不同顶点调用myPlane得到的法向量可能朝内也可能朝外，导致求解时找错交点。
• Solver参数未优化：默认的收敛精度、迭代次数不足，也没有约束坐标范围在棱锥内部，进一步提升了求解错误概率。

仅需替换myOffset3PlaneIntersection函数即可，其余代码无需改动：

Function myOffset3PlaneIntersection(irow, x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3, r1, r2, r3)
    Dim v1 As Variant, v2 As Variant, v3 As Variant
    Dim norm1 As Double, norm2 As Double, norm3 As Double
    ' 计算三个平面方程
    v1 = myPlane(x0, y0, z0, x2, y2, z2, x3, y3, z3)
    v2 = myPlane(x0, y0, z0, x3, y3, z3, x1, y1, z1)
    v3 = myPlane(x0, y0, z0, x1, y1, z1, x2, y2, z2)
    ' 计算法向量模长
    norm1 = Sqr(v1(0) ^ 2 + v1(1) ^ 2 + v1(2) ^ 2)
    norm2 = Sqr(v2(0) ^ 2 + v2(1) ^ 2 + v2(2) ^ 2)
    norm3 = Sqr(v3(0) ^ 2 + v3(1) ^ 2 + v3(2) ^ 2)
    ' 统一法向量方向：确保棱锥内部点代入平面方程值为负，保证偏移方向朝内
    If v1(0) * 0.25 + v1(1) * 0.25 + v1(2) * 0.25 + v1(3) > 0 Then
        v1(0) = -v1(0): v1(1) = -v1(1): v1(2) = -v1(2): v1(3) = -v1(3)
    End If
    If v2(0) * 0.25 + v2(1) * 0.25 + v2(2) * 0.25 + v2(3) > 0 Then
        v2(0) = -v2(0): v2(1) = -v2(1): v2(2) = -v2(2): v2(3) = -v2(3)
    End If
    If v3(0) * 0.25 + v3(1) * 0.25 + v3(2) * 0.25 + v3(3) > 0 Then
        v3(0) = -v3(0): v3(1) = -v3(1): v3(2) = -v3(2): v3(3) = -v3(3)
    End If
    ' 修正目标函数：点到平面有符号距离加上偏移值的残差平方和最小
    my1 = "((" & v1(0) & " * " & myR1C1toA1(irow, 1) & "+ " & v1(1) & " * " & myR1C1toA1(irow, 2) & "+ " & v1(2) & " * " & myR1C1toA1(irow, 3) & "+ " & v1(3) & ") / " & norm1 & " + " & r1 & ")"
    my2 = "((" & v2(0) & " * " & myR1C1toA1(irow, 1) & "+ " & v2(1) & " * " & myR1C1toA1(irow, 2) & "+ " & v2(2) & " * " & myR1C1toA1(irow, 3) & "+ " & v2(3) & ") / " & norm2 & " + " & r2 & ")"
    my3 = "((" & v3(0) & " * " & myR1C1toA1(irow, 1) & "+ " & v3(1) & " * " & myR1C1toA1(irow, 2) & "+ " & v3(2) & " * " & myR1C1toA1(irow, 3) & "+ " & v3(3) & ") / " & norm3 & " + " & r3 & ")"
    Range(myR1C1toA1(irow, 5)).Formula = "=" & my1 & "^ 2 +" & my2 & "^ 2 +" & my3 & "^ 2"
    
    ' 设置合理初始值：避免从0迭代陷入局部最优
    Range(myR1C1toA1(irow, 1)) = 0.25
    Range(myR1C1toA1(irow, 2)) = 0.25
    Range(myR1C1toA1(irow, 3)) = 0.25
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    SolverReset
    ' 增加坐标范围约束，限制在棱锥内部搜索
    SolverAdd CellRef:=ws.Range(myR1C1toA1(irow, 1) & ":" & myR1C1toA1(irow, 3)), Relation:=1, FormulaText:="1"
    SolverAdd CellRef:=ws.Range(myR1C1toA1(irow, 1) & ":" & myR1C1toA1(irow, 3)), Relation:=3, FormulaText:="0"
    SolverOk setCell:=ws.Range(myR1C1toA1(irow, 5)), _
                   MaxMinVal:=3, _
                   ByChange:=ws.Range(myR1C1toA1(irow, 1) & ":" & myR1C1toA1(irow, 3)), _
                   EngineDesc:="GRG Nonlinear"
    ' 调高求解精度
    SolverOptions Precision:=0.00001, Convergence:=0.00001, Iterations:=1000
    SolverSolve UserFinish:=True
End Function

修改后运行即可得到4行全部为0.250 0.250 0.250的预期结果。如果后续需要适配任意棱锥，把硬编码的初始值和法向量校验点替换为棱锥几何重心即可提升通用性。

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