[[20230526103631]]　『重なり合う2円の面積が全体に対してなん%かを算出』（うにゃ）　ページの最後に飛ぶ

『重なり合う2円の面積が全体に対してなん%かを算出』（うにゃ）

初めまして、うにゃともうします。
エクセルで重なる2円の面積が全体の面積の何%かを求めたいです。

条件としては
・直径 A1 mmの円1が存在します。(A1は任意でセル入力できるとありがたいです。)
・A2 mm右に並行移動した円2が存在します。(こちらも同様にA2に入力できる様にしていただけるとありがたいです。)
・この二つの円は重なりから外れると重なりの割合が0になるため
A1>0 , A2>0, A1>A2とします
・円1と円２が重なっている面積を C1 に算出
・円1と円２が成す図形(∞のような形)の面積を　C2 に算出
・C1÷C2した値を C3 に算出
(できればその図形を開いたスペースに作図させたいです)

以上のことをマクロを用いて作成させたいのですが、試行錯誤はしましたができませんでした。
困っているのでお願いしたいです。
わからないことがあれば聞いてください！
よろしくお願いしたいです！！！

＜使用 Excel：unknown、使用 OS：unknown ＞

確認です。

(1)2つの円は同じ大きさ（直径）でいいですか？
(2)同じ大きさの平行移動なら関数でも、できそですけどマクロ希望ですか？
（まる2021） 2023/05/26(金) 14:17:35

 返信ないですが、同一サイズの円の平行移動としてVBAで書いてみました。
 [A1]に直径(mm単位)、[B1]に平行移動距離(mm単位)を入力して、mainメソッドを実行してみてください。
 [C1]に交差部分の面積、[C2]に全体面積、[C3]に割合を表示、[D2]を左上として図形を作図します。
 答えの検証はそちらで、お願いします。
 以下はこちらで実行した結果です。

     __A  __B  __C________
 1   100   50  3070.924247
 2             12637.03902
 3             24.3%

 '2円の積集合の面積
Function CircleIntersect#(直径#, 移動#)
    Dim eval$
    eval = "(POWER(" & 直径 & "/2,2)*PI()*ACOS(" & 移動 & "/" & 直径 & ")/(2*PI())-" & 直径 & "*" & 移動 & "*SIN(ACOS(" & 移動 & "/" & 直径 & "))/8)*4"
    CircleIntersect = Evaluate(eval)
End Function
 '2円の和集合の面積
Function CircleUnion#(直径#, 移動#)
    Dim lap#
    lap = CircleIntersect(直径, 移動)
    CircleUnion = (直径 / 2) ^ 2 * WorksheetFunction.Pi * 2 - lap
End Function
 '2円を作図
Private Sub DrawCircle(直径#, 移動#, TopLeftCell As Range)
    Dim sp1 As Shape, sp2 As Shape, rng As Range
    Set sp1 = DrawCircleBase(直径, 0, TopLeftCell, rgbRed)
    Set sp2 = DrawCircleBase(直径, 移動, TopLeftCell, rgbBlue)
    ActiveSheet.Shapes.Range(Array(sp1.Name, sp2.Name)).Group
End Sub
 '単一円を作図。直径、移動はmm単位
Private Function DrawCircleBase(直径#, 移動#, TopLeftCell As Range, Optional 色, Optional 透過! = 0.5) As Shape
    Dim sp As Shape
    With TopLeftCell
        Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, _
                                             .Left + Application.CentimetersToPoints(移動 / 10), _
                                             .Top, _
                                             Application.CentimetersToPoints(直径 / 10), _
                                             Application.CentimetersToPoints(直径 / 10))
    End With
    If Not IsMissing(色) Then sp.Fill.ForeColor.RGB = 色
    sp.Fill.Transparency = 透過
    Set DrawCircleBase = sp
End Function
 '図形削除
Private Sub ShapsClear()
    Dim sp As Shape
    For Each sp In ActiveSheet.Shapes
        If sp.Type = msoGroup Then
            sp.Delete
        End If
    Next
End Sub
 Sub main()
    Dim 直径#, 移動#
    直径 = Range("A1").Value
    移動 = Range("B1").Value
    If 直径 < 0 Or 移動 < 0 Then Call MsgBox("直径と移動距離は正の値でないとダメです。", vbCritical): Exit Sub
    If 直径 < 移動 Then Call MsgBox("移動距離は直径以下でないとダメです。", vbCritical): Exit Sub
    Range("C1").Value = CircleIntersect(直径, 移動)
    Range("C2").Value = CircleUnion(直径, 移動)
    Range("C3").Value = Range("C1").Value / Range("C2").Value
    Range("C3").NumberFormatLocal = "0.0%"
    ShapsClear
    Call DrawCircle(直径, 移動, Range("D2"))
End Sub

（まる2021） 2023/05/26(金) 19:26:46

コメント返信：

[ 一覧(最新更新順) ]

[[20230526103631]] 『重なり合う2円の面積が全体に対してなん%かを算出』（うにゃ） ページの最後に飛ぶ

[[20230526103631]]　『重なり合う2円の面積が全体に対してなん%かを算出』（うにゃ）　ページの最後に飛ぶ