落點問題....(我目前從未到過的領域) - Excel程式區

1^# 跳轉到 »

發表於 2013-11-12 20:41 | 顯示全部帖子

回復 1# ui123
B區補完(6,6),(5,5)形成凹多邊形
判斷的演算法可以參考 http://www.csie.ntnu.edu.tw/~u91029/Polygon.html
裡面 判斷一個點是否在簡單多邊形內部裡面 這一段

2^#

發表於 2013-11-13 00:14 | 顯示全部帖子

本帖最後由 stillfish00 於 2013-11-13 00:27 編輯

回復 4# ui123
他是C/C++寫的，改成VBA大約如下

Function pointInPoly(ptx As Double, pty As Double, arPoly) As Boolean
Dim i As Long, j As Long
Dim pix As Double, piy As Double
Dim pjx As Double, pjy As Double
For i = 1 To UBound(arPoly) - 1
j = i + 1
pix = arPoly(i, 1): piy = arPoly(i, 2)
pjx = arPoly(j, 1): pjy = arPoly(j, 2)
'不包含點在多邊形線上
If Not (piy > pty) = (pjy > pty) Then
If ptx < (pjx - pix) * (pty - piy) / (pjy - piy) + pix Then pointInPoly = Not pointInPoly
End If
Next
End Function

複製代碼

利用他寫一個自訂函數RegionABC

Function RegionABC(x As Double, y As Double, RegionA As Range, RegionB As Range, RegionC As Range) As String
'不包含點在ABC邊緣
If pointInPoly(x, y, RegionA.Value) Then RegionABC = "A": Exit Function
If pointInPoly(x, y, RegionB.Value) Then RegionABC = "B": Exit Function
If pointInPoly(x, y, RegionC.Value) Then RegionABC = "C": Exit Function
RegionABC = "不在ABC"
End Function

複製代碼

先補齊B區的點，
使用，例如在O4公式打上 "=RegionABC(M4,N4,$C$4:$D$8,$C$10:$D$16,$C$18:$D$22)"

3^#

發表於 2013-11-14 12:06 | 顯示全部帖子

回復 10# ML089
自訂函數

Function PolyArea(rngPoly As Range)
Dim i As Long, j As Long
Dim pix As Double, piy As Double
Dim pjx As Double, pjy As Double
Dim arPoly, area As Double
arPoly = rngPoly.Value
If UBound(arPoly, 2) <> 2 _
Or arPoly(1, 1) <> arPoly(UBound(arPoly), 1) _
Or arPoly(1, 2) <> arPoly(UBound(arPoly), 2) Then PolyArea = CVErr(xlErrRef): Exit Function
area = 0
For i = 1 To UBound(arPoly) - 1
j = i + 1
pix = arPoly(i, 1): piy = arPoly(i, 2)
pjx = arPoly(j, 1): pjy = arPoly(j, 2)
area = area + pix * pjy
area = area - piy * pjx
Next
PolyArea = Abs(area) / 2
End Function

複製代碼

4^#

發表於 2013-11-14 22:11 | 顯示全部帖子

回復 19# ui123
修改如下，可含邊上的點，有優先順序(靠前的優先)
區域不限ABC三區可在參數自行增加，但要依參數順序。

Function pointInPoly(ptx As Double, pty As Double, arPoly) As Boolean
Dim i As Long, j As Long
Dim pix As Double, piy As Double
Dim pjx As Double, pjy As Double
For i = 1 To UBound(arPoly) - 1
j = i + 1
pix = arPoly(i, 1): piy = arPoly(i, 2)
pjx = arPoly(j, 1): pjy = arPoly(j, 2)
'多邊形邊上
If (pix - ptx) * (pjy - pty) - (piy - pty) * (pjx - ptx) = 0 And _
(pix - ptx) * (pjx - ptx) + (piy - pty) * (pjy - pty) <= 0 Then _
pointInPoly = True: Exit Function
'多邊形內部
If Not (piy > pty) = (pjy > pty) Then
If ptx < (pjx - pix) * (pty - piy) / (pjy - piy) + pix Then pointInPoly = Not pointInPoly
End If
Next
End Function
Function RegionABC(x As Double, y As Double, ParamArray polyRegion())
'3rd參數為A區，4th參數為B區。。。依此類推，越靠前的優先。
Dim i As Long, arPoly
For i = LBound(polyRegion) To UBound(polyRegion)
arPoly = polyRegion(i).Value
If UBound(arPoly, 2) <> 2 _
Or arPoly(1, 1) <> arPoly(UBound(arPoly), 1) _
Or arPoly(1, 2) <> arPoly(UBound(arPoly), 2) Then RegionABC = CVErr(xlErrRef): Exit Function
If pointInPoly(x, y, arPoly) Then
RegionABC = Chr(65 + i - LBound(polyRegion)) '依順位顯示A，B，C，D
Exit Function
End If
Next i
RegionABC = "不在範圍內"
End Function

複製代碼

5^#

發表於 2013-11-14 22:26 | 顯示全部帖子

回復 19# ui123
A區面積 =PolyArea(C4:D8)
這只是ML089大在10樓要我另外幫忙寫的算面積的函數。

[發問] 落點問題....(我目前從未到過的領域)