我正在研究一個宏來平均落在指定距離內的所有 GPS 坐標。我想不出一種方法來遍歷坐標串列以檢查串列中的任何其他坐標是否在 0.05 范圍內，然后平均坐標。
我玩過使用 if 陳述句和兩個坐標公式之間的距離
JoinD = Abs(((X1 - X2) ^ 2 (Y1 - Y2) ^ 2) ^ 0.5)
matchdist=0.05
If JoinD < matchdist Then..
更新：我一直在修改以下邏輯，我認為我在正確的軌道上
1cnt = 1
2cnt = 1
matchdist=0.05
For 1cnt = firstrow To lastcoordrow
X1 = Cells(1cnt, X1).Value
Y1 = Cells(1cnt, Y1).Value
Z1 = Cells(1cnt, Z1).Value
For 2cnt = firstrow To lastcoordrow
X2 = Cells(2cnt, X1).Value
Y2 = Cells(2cnt, Y1).Value
Z2 = Cells(2cnt, Z1).Value
joinD = Abs(((X1 - X2) ^ 2 (Y1 - Y2) ^ 2) ^ 0.5)
If joinD < matchdist And joinD > 0 Then
sumX = sumX X2
sumY = sumY Y2
sumZ = sumZ Z2
noofmatches = noofmatches 1
Next
然后有一些邏輯將每個 sumX/sumy/sumZ 值除以匹配數
但我無法得到任何作業。理想的結果是把這些資料
非平均坐標
進入這個資料
平均坐標
uj5u.com熱心網友回復：
將坐標集合分組到字典中，然后回圈通過它們在單獨的函式中計算平均值。
Option Explicit
Sub Calc()
Dim ws As Worksheet
Dim dict As Object, k, coord
Dim lastrow As Long, i As Long
Dim id As String
Dim x1 As Double, y1 As Double, z1 As Double
Set dict = CreateObject("Scripting.Dictionary")
Set ws = Sheets(1)
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
id = Trim(.Cells(i, "B"))
x1 = .Cells(i, "C")
y1 = .Cells(i, "D")
z1 = .Cells(i, "E")
If Len(id) > 0 And Not dict.exists(id) Then
dict.Add id, New Collection
End If
dict(id).Add Array(x1, y1, z1)
Next
End With
' result sheet2
Dim rng As Range
With Sheet2
Set rng = .Cells(1, 1)
For Each k In dict.keys
id = CStr(k)
coord = CalcAvg(dict(k))
rng.Value = id
rng.Offset(0, 1) = Format(coord(0), "0.000")
rng.Offset(0, 2) = Format(coord(1), "0.000")
rng.Offset(0, 3) = Format(coord(2), "0.000")
rng.Offset(0, 4) = Format(coord(3), "0")
Set rng = rng.Offset(1)
Next
.Columns("A:D").AutoFit
End With
End Sub
Function CalcAvg(c As Collection) As Variant
Const T = 0.05
Dim x1 As Double, y1 As Double, z1 As Double
Dim x As Double, y As Double, d As Double
Dim xSum As Double, ySum As Double, zSum As Double
Dim i As Long, j As Long, n As Long
' calc average
For i = 1 To c.Count
x1 = c.Item(i)(0)
y1 = c.Item(i)(1)
z1 = c.Item(i)(2)
For j = 1 To c.Count
If i <> j Then
x = Abs(x1 - c.Item(j)(0))
y = Abs(y1 - c.Item(j)(1))
' check tolerance
If x > T Or y > T Then
' ignore
Else
d = (x ^ 2 y ^ 2) ^ 0.5
If d <= T Then
n = n 1
xSum = xSum x1
ySum = ySum y1
zSum = zSum z1
End If
End If
End If
Next
Next
If n > 0 Then
CalcAvg = Array(xSum / n, ySum / n, zSum / n, n)
Else
CalcAvg = Array(0, 0, 0, 0)
End If
End Function
uj5u.com熱心網友回復：
部分回答
我很好奇你用這個去哪里。
我制作了一些類似的出現資料，并在單獨的作業表上構建了一個矩陣。也許這會讓你知道下一步該去哪里，因為我不確定。
Option Explicit
Function joinD(X1 As Double, Y1 As Double, X2 As Double, Y2 As Double) As Double
joinD = Abs(((X1 - X2) ^ 2 (Y1 - Y2) ^ 2) ^ 0.5)
End Function
Sub test_GPS()
Dim lastrow As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim i As Long
Dim j As Long
Dim dist As Double
Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)
Dim coord1() As Double
Dim coord2() As Double
lastrow = sh1.Range("D" & sh1.Rows.Count).End(xlUp).Row
If lastrow > (sh2.Columns.Count - 3) Then Exit Sub 'This won't work if more data than columns exist.
ReDim coord1(1 To lastrow, 1 To 2)
ReDim coord2(1 To lastrow, 1 To 2)
With sh1.Range("D1:D" & lastrow)
.Copy Destination:=sh2.Range("A2")
.Copy
End With
sh2.Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
For i = 1 To lastrow
coord1(i, 1) = sh1.Range("B" & i).Value
coord1(i, 2) = sh1.Range("C" & i).Value
For j = 1 To lastrow
coord2(j, 1) = sh1.Range("B" & j).Value
coord2(j, 2) = sh1.Range("C" & j).Value
dist = joinD(coord1(i, 2), coord1(i, 1), coord2(j, 2), coord2(j, 1))
sh2.Cells(i 1, j 1).Value = dist
Next j
Next i
End Sub
你幾乎肯定需要調整它，但這是一個起點。將來我可能會對類似的東西有類似的需求，所以我對你最終專案的樣子很感興趣。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/407580.html
標籤：