第二张表查找第一张表名字和经纬度，并计算2个点的距离，大于350米标绿

zzwjq · 发表于 2016-1-23 09:02

第二张表查找第一张表名字和经纬度，并计算2个点的距离，大于350米标绿，详见附件

zzwjq · 发表于 2016-1-23 09:04

附件如下，请高手帮忙看看

xiahuaxian · 发表于 2016-1-23 09:16

查找倒是不难，只是计算距离非常人专业，不会，你能给出计算方法吗？

zzwjq · 发表于 2016-1-23 10:41

在线等。。。。

gbgbxgb · 发表于 2016-1-23 11:28

上个图片，帮顶：

一指禅62 · 发表于 2016-1-23 11:47

本帖最后由一指禅62 于 2016-1-23 12:24 编辑

拼凑的，不知对不对？

Sub 测距()
'C = sin(MLatA)*sin(MLatB)*cos(MLonA-MLonB) + cos(MLatA)*cos(MLatB)
' (MLonA, MLatA)和(MLonB, MLatB)
Dim MLonA As Double, MLatA As Double 'A点的经纬度
Dim MLonB As Double, MLatB As Double 'B点的经纬度
Dim C As Double 'A、B间的距离
Dim Rng As Range, i%, key$
Dim myTrue As Boolean
Const R = 6371004 '地球的平均半径，单位：米
Const Pi = 3.1415936
myTrue = True
With Sheet2.Range("C2:G65536")
.ClearContents
.Font.ColorIndex = 0
.Interior.ColorIndex = xlNone
End With
For i = 2 To Sheet2.Range("A65536").End(3).Row
key = Sheet2.Cells(i, 1)
Set Rng = Sheet1.Range("A:A").Find(key, lookat:=xlWhole)
If Not Rng Is Nothing Then
Sheet2.Cells(i, 3) = Rng.Offset(0, 1)
MLonA = Rng.Offset(0, 2) 'A点的经度
MLatA = Rng.Offset(0, 3) 'A点的纬度
Else
myTrue = False
End If
key = Sheet2.Cells(i, 2)
Set Rng = Sheet1.Range("A:A").Find(key, lookat:=xlWhole)
If Not Rng Is Nothing Then
Sheet2.Cells(i, 4) = Rng.Offset(0, 1)
MLonB = Rng.Offset(0, 2) 'B点的经度
MLatB = Rng.Offset(0, 3) 'B点的纬度
Else
myTrue = False
End If
If myTrue Then
C = R * WorksheetFunction.Acos(Sin(MLatA) * Sin(MLatB) * Cos(MLonA - MLonB) + Cos(MLatA) * Cos(MLatB)) * Pi / 180
C = WorksheetFunction.Round(C, 0)
With Sheet2.Cells(i, 5)
.Value = C
If C > 350 Then
.Interior.ColorIndex = 50
.Font.ColorIndex = 2
End If
End With
End If
Next
End Sub

复制代码

一指禅62 · 发表于 2016-1-23 12:26

本帖最后由一指禅62 于 2016-1-23 12:35 编辑

主辅.zip (12.69 KB, 下载次数: 24)

opiona · 发表于 2016-1-23 12:35

给你个计算距离的自定义函数：

'//********** 计算2个经纬度之间的距离 **************
'函数名： GetDistance
'返回值：距离，米，和常数：EARTH_RADIUS 的单位相同
'参数1对： JingDu1 经度，WeiDu1 纬度
'参数2对： JingDu2 经度，WeiDu2 纬度
'使用方法：MsgBox "距离是：" & GetDistance(JingDu1, WeiDu1, JingDu2, WeiDu2) & "米"
' 整理：北极狐工作室 QQ：14885553
'**************
Private Const EARTH_RADIUS = 6371004 '//这里地球半径单位：米
Const EarthRadius = 6378.137
Private Function GetDistance(ByVal JingDu1 As Double, ByVal WeiDu1 As Double, ByVal JingDu2 As Double, ByVal WeiDu2 As Double) As Double
s = Application.Acos(Sin(WeiDu1 / 180 * Application.WorksheetFunction.Pi()) * Sin(WeiDu2 / 180 * Application.WorksheetFunction.Pi()) + Cos(WeiDu1 / 180 * Application.WorksheetFunction.Pi()) * Cos(WeiDu2 / 180 * Application.WorksheetFunction.Pi()) * Cos(JingDu2 / 180 * Application.WorksheetFunction.Pi() - JingDu1 / 180 * Application.WorksheetFunction.Pi())) * EARTH_RADIUS
GetDistance = Round(s * 10000) / 10000
End Function
'//****************************************************
Function Rad(d)
Rad = d * Application.WorksheetFunction.Pi / 180#
End Function
Function Distance(Lon1, Lat1, Lon2, Lat2)
Dim RadLat1 As Double
Dim RadLat2 As Double
Dim a As Double
Dim b As Double
Dim s As Double
RadLat1 = Rad(Lat1)
RadLat2 = Rad(Lat2)
a = RadLat1 - RadLat2
b = Rad(Lon1) - Rad(Lon2)
s = 2 * Application.WorksheetFunction.Asin(Sqr(Sin(a / 2) ^ 2 + Cos(RadLat1) * Cos(RadLat2) * (Sin(b / 2) ^ 2)))
s = s * EarthRadius
Distance = s
End Function

复制代码

hhjjpp · 发表于 2016-1-23 17:12

Y2015-h.rar (13.26 KB, 下载次数: 23)

hhjjpp · 发表于 2016-1-23 17:25

本帖最后由 hhjjpp 于 2016-1-23 19:43 编辑

把地球看成近似球体，两点距离即为通过两点及球心的剖面之圆弧长，该圆半径为球径
从两点作赤道平面的垂线，其两点之弦及其在赤道平面的投影，构成一个四面椎的底面（直角梯形），四条棱均为地球半径（或其一段）
棱锥其中三个面为：两点各自的经度剖面、地球赤道平面

用户名		自动登录	找回密码
密码			免费注册

[求助] 第二张表查找第一张表名字和经纬度，并计算2个点的距离，大于350米标绿

浏览过的版块