【エクセルVBA】平面上にある２直線の交点座標を算出する方法！

こんにちは、ヒガシです。

このページでは以下の画像に示すように平面上にある２直線の交点座標を算出する方法をご紹介していきます。

あなたがやることは各直線を構成する４点a,b,c,dのX,Y座標を指定するだけでOKです。

それではさっそくやっていきましょう！

２直線の交点座標を算出する方法の解説

まずはどうやって２直線の交点を算出するか説明していきます。

やることはいたってシンプルです。

まずは以下の画像に示すように２つの直線上それぞれに点P,Qを適当に取り、その２点を結ぶ線分PQの長さを計測します。

この作業をP,Qの位置を網羅的に変更しながら実施し、線分PQの長さが最小になるP,Qの座標を探索していきます。

※うまく計算できれば最終的にP,Qの座標は一致することになります。

手計算でやればもっと数学的に説くことは可能ですが、コンピューターはそういった計算は得意ではないので、上記で説明したような探索的な計算で解いていきます。

VBAの実行環境を構築しておく

実際の作業に入る前に、今回はＶＢＡを使って計算していきます。

ＶＢＡを使ったことがない、という方は以下を参考に実行環境を整えておきましょう。

エクセルマクロ（VBA)の始め方！初心者向けに画像を使って詳細解説

２直線を構成する４点の座標を指定する

交点を計算する上で、まずは２つの直線がなければ話になりません。

というわけでまずは２つの直線を構成する４点の座標を指定してあげましょう。

今回は以下のようにエクセル上に記述しました。

※グラフは作ってなくてもＯＫです。

なお、以降のプログラムは上の画像と同じセルにa,b,c,dの座標情報があることを前提に書いています。

セルの位置を変更すると以降のプログラムは機能しませんのでご注意ください。

また、計算の過程でその他のセルも使用します。

必ず新規シート上で実行するようにしてください。

２直線の交点を算出するサンプルコード

それでは前置きはこのくらいにして、先ほど指定して２直線の交点を求めるプログラムを書いていきましょう。

以下がそのコードです。

Sub search_main()
    Dim sea_delta As Integer
    Dim num_search As Integer
    Dim sea_max As Single, sea_min As Single
    Call pre_set(1)
    Application.ScreenUpdating = Flase
    Range("K1:ZZ500").ClearContents
    sea_max = 20
    sea_min = -20
    sea_delta = 20
    num_search = 20
    s_max = sea_max
    t_max = sea_max
    s_min = sea_min
    t_min = sea_min
    For k = 1 To num_search
        Call draw_matrix_s(s_max, s_min, sea_delta)
        Call draw_matrix_t(t_max, t_min, sea_delta)
        Call search_L(s_max, s_min, t_max, t_min, sea_delta)
        st = search_index(sea_delta)
        s_max = st(0)
        s_min = st(1)
        t_max = st(2)
        t_min = st(3)
    Next
    Range("K1:ZZ500").ClearContents
End Sub
Sub pre_set(a)
    Range("A1:H8").Font.Bold = True
    Range("A7:B8").Borders.Weight = xlThin
    Range("F1:H3").Borders.Weight = xlThin
    Range("F5:G5").Borders.Weight = xlThin
    Range("F7:H8").Borders.Weight = xlThin
    Range("A7") = "s"
    Range("A8") = "t"
    Range("G1") = "X"
    Range("H1") = "Y"
    Range("F2") = "P"
    Range("F3") = "Q"
    Range("F5") = "PQ_Distance"
    Range("F8") = "PQ_Center"
    Range("G7") = "X"
    Range("H7") = "Y"
    Range("G2") = "=(B3-B2)*$B$7+B2"
    Range("H2") = "=(C3-C2)*$B$7+C2"
    Range("G3") = "=(B5-B4)*$B$8+B4"
    Range("H3") = "=(C5-C4)*$B$8+C4"
    Range("G5") = "=SQRT((G3-G2)^2+(H3-H2)^2+(I3-I2)^2)"
    Range("G8") = "=(G2+G3)/2"
    Range("H8") = "=(H2+H3)/2"
End Sub
Sub draw_matrix_s(sea_max, sea_min, sea_delta)
    For i = 0 To sea_delta
        Cells(2 + i, 11) = sea_min + (sea_max - sea_min) / sea_delta * i
    Next
End Sub
Sub draw_matrix_t(sea_max, sea_min, sea_delta)
    For i = 0 To sea_delta
        Cells(1, 12 + i) = sea_min + (sea_max - sea_min) / sea_delta * i
    Next
End Sub
Sub search_L(s_max, s_min, t_max, t_min, sea_delta)
    For ss = 0 To sea_delta
        s = Cells(2 + ss, 11)
        For tt = 0 To sea_delta
            t = Cells(1, 12 + tt)
            Range("B7") = s
            Range("B8") = t
            Cells(2 + ss, 12 + tt) = Range("G5")
        Next
    Next
End Sub

Function search_index(sea_delta)
    Dim return_val(3) As Single
    data_array = Range(Cells(2, 12), Cells(2 + sea_delta, 12 + sea_delta))
    min_value = Application.WorksheetFunction.Min(data_array)
    For i = 1 To UBound(data_array, 1)
        For j = 1 To UBound(data_array, 2)
            If data_array(i, j) = min_value Then
                max_r = Application.WorksheetFunction.Min(1 + i + 2, 2 + sea_delta)
                min_r = Application.WorksheetFunction.Max(1 + i - 2, 2)
                max_c = Application.WorksheetFunction.Min(11 + j + 2, 12 + sea_delta)
                min_c = Application.WorksheetFunction.Max(11 + j - 2, 12)
                s_max = Cells(max_r, 11) + Cells(max_r, 11) - Cells(max_r - 2, 11)
                s_min = Cells(min_r, 11) - (Cells(min_r + 2, 11) - Cells(min_r, 11))
                t_max = Cells(1, max_c) + Cells(1, max_c) - Cells(1, max_c - 2)
                t_min = Cells(1, min_c) - (Cells(1, max_c + 2) - Cells(1, max_c))
            End If
        Next
    Next
    return_val(0) = s_max
    return_val(1) = s_min
    return_val(2) = t_max
    return_val(3) = t_min
    search_index = return_val
End Function

先ほども説明した通り、今回は探索的に交点座標を求めていきます。

そのため探索範囲はあらかじめ指定しておく必要があります。

それを行っているのが、７，８行目です。（sea_max、sea_min）

もしこの指定範囲内に解がなければ正しい値を求めることはできませんのでなるべく広範囲を指定しておく必要があります。

ただし、広範囲すぎると探索が粗くなりますので９行目の探索の細かさ（sea_delta）を大きくするか探索回数（num_search）を大きくする必要がでてきます。

しかしながらこれらの数値は大きくすればするほど計算時間はかかってしまいますのでその点はご注意ください。

サンプルコードの実行結果確認

それでは先ほどのサンプルコードを実行してみましょう。

いざ、実行！！！

※少し時間がかかります。

計算が終わると以下の結果が算出されました。

G8,H8セルに記入されている情報が今回求めたい２直線のX,Y座標になります。

右側のグラフと照らし合わせてみても、目視でわかる交点座標を付近をしてしていることがわかると思います。

また、G5セルには交点を求める際に線分PQの長さを出力しています。

探索的に求める手法ですので、完璧に０ではないですが、問題なくほぼ０になっていますね。

というわけで問題なく交点座標を算出できていそうですね。

おわりに

というわけで今回は、エクセルVBAをつかって平面上にある２直線の交点座標を算出する方法をご紹介しました。

設計の際などにぜひご活用ください。

※あくまでも自己責任でお願いします。

このように、私のブログではエクセルスキルはもちろん、様々なプログラミングスキルを紹介しています。

今は仕事中で時間がないかもしれませんが、ぜひ通勤時間中などに他の記事も読んでいただけると嬉しいです。

⇒興味をもった方は【ヒガサラ】で検索してみてください。

確実にスキルアップできるはずです。

最後に、この記事が役に立ったという方は、ぜひ応援よろしくお願いします。

↓ 応援ボタン

にほんブログ村

それではまた！

Follow @HigashiSalary