

①四面体(三角錐)の内接球のsympyを探しています。他言語でも。  
②vbaソルバーで実行してみました。vbaコードを短くする方法を教えて下さい。一例しか実行していません。  
➂以下のコードの、「Range("A7").Formula」複数行で書けませんでした。  
よろしくお願いします。

オリジナルポスト  
(0,0,0),(1,0,0),(0,1,0),(0,0,2)  
「2021年度 九州大・理系数学問題1(1)」  
<https://www.densu.jp/kyusyu/21kyusyuspass.pdf>

参考  
「CASIO＞３点を含む平面の式,４点で形成される四面体の体積」  
<https://keisan.casio.jp/exec/system/1202458197>  
<https://keisan.casio.jp/exec/system/1202458218>  
「Wolfram|Alpha」  
<https://ja.wolframalpha.com/input/?i=%280%2C0%2C0%29%2C%281%2C0%2C0%29%2C%280%2C1%2C0%29%2C%280%2C0%2C2%29>  
<https://ja.wolframalpha.com/input/?i=%E4%B8%89%E8%A7%92%E9%8C%90%EF%BC%880%2C0%2C0%29%2C%281%2C0%2C0%29%2C%280%2C1%2C0%29%2C%280%2C0%2C2%29>

[code]

    Const Ax = 0
    Const Ay = 0
    Const Az = 0
    Const Bx = 1
    Const By = 0
    Const Bz = 0
    Const Cx = 0
    Const Cy = 1
    Const Cz = 0
    Const Dx = 0
    Const Dy = 0
    Const Dz = 2
    Function myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
       a = (By - Ay) * (Cz - Az) - (Cy - Ay) * (Bz - Az)
       b = (Bz - Az) * (Cx - Ax) - (Cz - Az) * (Bx - Ax)
       c = (Bx - Ax) * (Cy - Ay) - (Cx - Ax) * (By - Ay)
       d = -(a * Ax + b * Ay + c * Az)
       myHeimen = Array(a, b, c, d)
    End Function
    Function mySimentaiTaiseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
       mySimentaiTaiseki = _
                         ((x4 - x1) * Abs(y2 - y1) * (z3 - z1) - (z3 - z1) * (y3 - y1) _
                        + (y4 - y1) * Abs(z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) _
                        + (z4 - z1) * Abs(x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)) / 6#
    End Function
    Function myDis(x1, y1, z1, x2, y2, z2)
        myDis = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)
    End Function
    Function myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3)
        s = (myDis(x1, y1, z1, x2, y2, z2) + myDis(x2, y2, z2, x3, y3, z3) + myDis(x3, y3, z3, x1, y1, z1)) / 2#
        myHeron = Sqr(s * (s - myDis(x1, y1, z1, x2, y2, z2)) * (s - myDis(x2, y2, z2, x3, y3, z3)) * (s - myDis(x3, y3, z3, x1, y1, z1)))
    End Function
    Function mySimentaiMenseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
        mySimentaiMenseki = _
            myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3) _
          + myHeron(x2, y2, z2, x3, y3, z3, x4, y4, z4) _
          + myHeron(x3, y3, z3, x4, y4, z4, x1, y1, z1) _
          + myHeron(x4, y4, z4, x1, y1, z1, x2, y2, z2)
    End Function
    Sub aaa_Sankakusui()
        Dim vD As Variant
        Dim vA As Variant
        Dim vB As Variant
        Dim vC As Variant
        ActiveSheet.Cells.Clear
    '
    MsgBox "四面体(三角錐)の内接球をソルバーで計算します。"
    '
        Range("A1") = Ax
        Range("B1") = Ay
        Range("C1") = Az
        Range("A2") = Bx
        Range("B2") = By
        Range("C2") = Bz
        Range("A3") = Cx
        Range("B3") = Cy
        Range("C3") = Cz
        Range("A4") = Dx
        Range("B4") = Dy
        Range("C4") = Dz
        Range("A5") = mySimentaiTaiseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        Range("B5") = mySimentaiMenseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        Range("C5").Formula = "= A5*3.0/B5"
    '
        vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
        vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
        vC = myHeimen(Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
    '       "
        Range("E1") = vD(0)
        Range("F1") = vD(1)
        Range("G1") = vD(2)
        Range("H1") = vD(3)
        Range("E2") = vA(0)
        Range("F2") = vA(1)
        Range("G2") = vA(2)
        Range("H2") = vA(3)
        Range("E3") = vB(0)
        Range("F3") = vB(1)
        Range("G3") = vB(2)
        Range("H3") = vB(3)
        Range("E4") = vC(0)
        Range("F4") = vC(1)
        Range("G4") = vC(2)
        Range("H4") = vC(3)
        Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2  + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - C5) ^ 2"
        Dim ws As Worksheet: Set ws = ActiveSheet
        SolverReset
        SolverOk setCell:=ws.Range("A7"), _
                       MaxMinVal:=3, _
                       ByChange:=ws.Range("A6:C6"), _
                       EngineDesc:="GRG Nonlinear"
         SolverSolve UserFinish:=True
    End Sub
    '結果
    '半径　0.249999801614916
    '四面体に内接する球の中心座標　0.249999705 0.249999822 0.249999802
    
[/code]


CC BY-SA 4.0
2021-10-11T13:13:03.190
83009
2021-10-14T12:42:27.213
17199
question
vba sympy
四面体(三角錐)の内接球のsympyを探しています。 vbaソルバーでやってみました。


vbaソルバー（その2)  
変化させるセル(変数セル) に球の半径も追加しました。その結果、表面積と体積の計算が不要になりました。

[code]

    Const Ax = 0
    Const Ay = 0
    Const Az = 0
    Const Bx = 1
    Const By = 0
    Const Bz = 0
    Const Cx = 0
    Const Cy = 1
    Const Cz = 0
    Const Dx = 0
    Const Dy = 0
    Const Dz = 2
    Function myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
       a = (By - Ay) * (Cz - Az) - (Cy - Ay) * (Bz - Az)
       b = (Bz - Az) * (Cx - Ax) - (Cz - Az) * (Bx - Ax)
       c = (Bx - Ax) * (Cy - Ay) - (Cx - Ax) * (By - Ay)
       d = -(a * Ax + b * Ay + c * Az)
       myHeimen = Array(a, b, c, d)
    End Function
    Sub aaa_Sankakusui()
        Dim vD As Variant
        Dim vA As Variant
        Dim vB As Variant
        Dim vC As Variant
        ActiveSheet.Cells.Clear
    '
    MsgBox "'四面体(三角錐)の内接球をソルバーで計算します。"
    '
        Range("A1") = Ax
        Range("B1") = Ay
        Range("C1") = Az
        Range("A2") = Bx
        Range("B2") = By
        Range("C2") = Bz
        Range("A3") = Cx
        Range("B3") = Cy
        Range("C3") = Cz
        Range("A4") = Dx
        Range("B4") = Dy
        Range("C4") = Dz
    '
        vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
        vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
        vC = myHeimen(Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
    '       "
        Range("E1") = vD(0)
        Range("F1") = vD(1)
        Range("G1") = vD(2)
        Range("H1") = vD(3)
        Range("E2") = vA(0)
        Range("F2") = vA(1)
        Range("G2") = vA(2)
        Range("H2") = vA(3)
        Range("E3") = vB(0)
        Range("F3") = vB(1)
        Range("G3") = vB(2)
        Range("H3") = vB(3)
        Range("E4") = vC(0)
        Range("F4") = vC(1)
        Range("G4") = vC(2)
        Range("H4") = vC(3)
        Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - D6) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - D6) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - D6) ^ 2  + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - D6) ^ 2"
        Dim ws As Worksheet: Set ws = ActiveSheet
        SolverReset
        SolverOk setCell:=ws.Range("A7"), _
                       MaxMinVal:=3, _
                       ByChange:=ws.Range("A6:D6"), _
                       EngineDesc:="GRG Nonlinear"
         SolverSolve UserFinish:=True
    End Sub
    '結果
    '半径 0.249999512642834
    '四面体に内接する球の中心座標 0.250000201 0.249999942 0.249998773
    
[/code]


CC BY-SA 4.0
2021-10-12T10:31:11.300
83040
2021-10-12T10:31:11.300
17199
83009
answer


vbaソルバー（その3)  
(その1) について、球の半径を計算しているので、4番目の垂線計算が不要でした。

[code]

       Const Ax = 0
       Const Ay = 0
       Const Az = 0
       Const Bx = 1
       Const By = 0
       Const Bz = 0
       Const Cx = 0
       Const Cy = 1
       Const Cz = 0
       Const Dx = 0
       Const Dy = 0
       Const Dz = 2
       Function myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
          a = (By - Ay) * (Cz - Az) - (Cy - Ay) * (Bz - Az)
          b = (Bz - Az) * (Cx - Ax) - (Cz - Az) * (Bx - Ax)
          c = (Bx - Ax) * (Cy - Ay) - (Cx - Ax) * (By - Ay)
          d = -(a * Ax + b * Ay + c * Az)
          myHeimen = Array(a, b, c, d)
       End Function
       Function mySimentaiTaiseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
          mySimentaiTaiseki = _
                            ((x4 - x1) * Abs(y2 - y1) * (z3 - z1) - (z3 - z1) * (y3 - y1) _
                           + (y4 - y1) * Abs(z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) _
                           + (z4 - z1) * Abs(x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)) / 6#
       End Function
       Function myDis(x1, y1, z1, x2, y2, z2)
           myDis = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)
       End Function
       Function myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3)
           s = (myDis(x1, y1, z1, x2, y2, z2) + myDis(x2, y2, z2, x3, y3, z3) + myDis(x3, y3, z3, x1, y1, z1)) / 2#
           myHeron = Sqr(s * (s - myDis(x1, y1, z1, x2, y2, z2)) * (s - myDis(x2, y2, z2, x3, y3, z3)) * (s - myDis(x3, y3, z3, x1, y1, z1)))
       End Function
       Function mySimentaiMenseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
           mySimentaiMenseki = _
               myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3) _
             + myHeron(x2, y2, z2, x3, y3, z3, x4, y4, z4) _
             + myHeron(x3, y3, z3, x4, y4, z4, x1, y1, z1) _
             + myHeron(x4, y4, z4, x1, y1, z1, x2, y2, z2)
       End Function
       Sub aaa_Sankakusui()
           Dim vD As Variant
           Dim vA As Variant
           Dim vB As Variant
           Dim vC As Variant
           ActiveSheet.Cells.Clear
       '
       MsgBox "四面体(三角錐)の内接球をソルバーで計算します。"
       '
           Range("A1") = Ax
           Range("B1") = Ay
           Range("C1") = Az
           Range("A2") = Bx
           Range("B2") = By
           Range("C2") = Bz
           Range("A3") = Cx
           Range("B3") = Cy
           Range("C3") = Cz
           Range("A4") = Dx
           Range("B4") = Dy
           Range("C4") = Dz
           Range("A5") = mySimentaiTaiseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
           Range("B5") = mySimentaiMenseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
           Range("C5").Formula = "= A5*3.0/B5"
       '
           vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
           vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
           vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
       '       "
           Range("E1") = vD(0)
           Range("F1") = vD(1)
           Range("G1") = vD(2)
           Range("H1") = vD(3)
           Range("E2") = vA(0)
           Range("F2") = vA(1)
           Range("G2") = vA(2)
           Range("H2") = vA(3)
           Range("E3") = vB(0)
           Range("F3") = vB(1)
           Range("G3") = vB(2)
           Range("H3") = vB(3)
           Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2"
           Dim ws As Worksheet: Set ws = ActiveSheet
           SolverReset
           SolverOk setCell:=ws.Range("A7"), _
                          MaxMinVal:=3, _
                          ByChange:=ws.Range("A6:C6"), _
                          EngineDesc:="GRG Nonlinear"
            SolverSolve UserFinish:=True
       End Sub
       '結果
       '半径 0.25
       '四面体に内接する球の中心座標 0.249999819 0.249999981 0.25000015
    
    
[/code]


CC BY-SA 4.0
2021-10-13T10:29:35.660
83072
2021-10-13T10:29:35.660
17199
83009
answer


vbaソルバー（その4)  
関数にしました。【A1形式】を【R1C1形式】にしました。

[code]

    Const Ax = 0
    Const Ay = 0
    Const Az = 0
    Const Bx = 1
    Const By = 0
    Const Bz = 0
    Const Cx = 0
    Const Cy = 1
    Const Cz = 0
    Const Dx = 0
    Const Dy = 0
    Const Dz = 2
    Function myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
       a = (By - Ay) * (Cz - Az) - (Cy - Ay) * (Bz - Az)
       b = (Bz - Az) * (Cx - Ax) - (Cz - Az) * (Bx - Ax)
       c = (Bx - Ax) * (Cy - Ay) - (Cx - Ax) * (By - Ay)
       d = -(a * Ax + b * Ay + c * Az)
       myHeimen = Array(a, b, c, d)
    End Function
    Function mySimentaiTaiseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
       mySimentaiTaiseki = _
                         ((x4 - x1) * Abs(y2 - y1) * (z3 - z1) - (z3 - z1) * (y3 - y1) _
                        + (y4 - y1) * Abs(z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) _
                        + (z4 - z1) * Abs(x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)) / 6#
    End Function
    Function myDis(x1, y1, z1, x2, y2, z2)
        myDis = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)
    End Function
    Function myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3)
        s = (myDis(x1, y1, z1, x2, y2, z2) + myDis(x2, y2, z2, x3, y3, z3) + myDis(x3, y3, z3, x1, y1, z1)) / 2#
        myHeron = Sqr(s * (s - myDis(x1, y1, z1, x2, y2, z2)) * (s - myDis(x2, y2, z2, x3, y3, z3)) * (s - myDis(x3, y3, z3, x1, y1, z1)))
    End Function
    Function mySimentaiMenseki(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
        mySimentaiMenseki = _
            myHeron(x1, y1, z1, x2, y2, z2, x3, y3, z3) _
          + myHeron(x2, y2, z2, x3, y3, z3, x4, y4, z4) _
          + myHeron(x3, y3, z3, x4, y4, z4, x1, y1, z1) _
          + myHeron(x4, y4, z4, x1, y1, z1, x2, y2, z2)
    End Function
    Function myR1C1toA1(i, j)
        myR1C1toA1 = Application.ConvertFormula("R" & i & "C" & j, xlR1C1, xlA1)
    End Function
    Function myNainaisetukyu(igyo, iretu, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
        Dim vD As Variant
        Dim vA As Variant
        Dim vB As Variant
        Dim vC As Variant
    '
        myTaiseki = mySimentaiTaiseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        myMenseki = mySimentaiMenseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        myR = myTaiseki * 3# / myMenseki
        vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
        vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
        vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
    '
        myD = "(Abs(" & vD(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vD(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vD(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vD(3) & ") / Sqrt(" & vD(0) & " ^ 2 + " & vD(1) & " ^ 2 +" & vD(2) & " ^ 2) - " & myR & ")"
        myA = "(Abs(" & vA(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vA(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vA(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vA(3) & ") / Sqrt(" & vA(0) & " ^ 2 + " & vA(1) & " ^ 2 +" & vA(2) & " ^ 2) - " & myR & ")"
        myB = "(Abs(" & vB(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vB(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vB(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vB(3) & ") / Sqrt(" & vB(0) & " ^ 2 + " & vB(1) & " ^ 2 +" & vB(2) & " ^ 2) - " & myR & ")"
        Range(myR1C1toA1(igyo, iretu + 4)).Formula = "=" & myD & "^ 2 +" & myA & "^ 2 +" & myB & "^ 2"
    '
        Dim ws As Worksheet: Set ws = ActiveSheet
        SolverReset
        SolverOk setCell:=ws.Range(myR1C1toA1(igyo, iretu + 4)), _
                       MaxMinVal:=3, _
                       ByChange:=ws.Range(myR1C1toA1(igyo, iretu) & ":" & myR1C1toA1(igyo, iretu + 2)), _
                       EngineDesc:="GRG Nonlinear"
         SolverSolve UserFinish:=True
    
         myNainaisetukyu = Array(Range(myR1C1toA1(igyo, iretu)).Value, Range(myR1C1toA1(igyo, iretu + 1)).Value, Range(myR1C1toA1(igyo, iretu)).Value, myR)
    End Function
    Sub aaa_Sankakusui()
        Dim myXYZR As Variant
        ActiveSheet.Cells.Clear
        igyo = 1
        iretu = 4
        myXYZR = myNainaisetukyu(igyo, iretu, Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Cx, Cy, Cz)
        Cells(1, 1) = Ax
        Cells(1, 2) = Ay
        Cells(1, 3) = Az
        Cells(2, 1) = Bx
        Cells(2, 2) = By
        Cells(2, 3) = Bz
        Cells(3, 1) = Cx
        Cells(3, 2) = Cy
        Cells(3, 3) = Cz
        Cells(4, 1) = Dx
        Cells(4, 2) = Dy
        Cells(4, 3) = Dz
        Cells(igyo, iretu + 3) = myXYZR(3)
        Cells(igyo, iretu + 4) = ""
    End Sub
    '結果
    '四面体に内接する球の中心座標と半径 0.249999819 0.249999981 0.25000015  0.25
    
[/code]


CC BY-SA 4.0
2021-10-14T12:42:27.213
83097
2021-10-14T12:42:27.213
17199
83009
answer