平均近距离 GPS 坐标

Question

我正在开发一个宏来平均落在指定距离内的所有 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 值除以匹配数

但是我什么也做不了。理想的结果是将此数据

非平均坐标

进入这个数据

平均坐标

CDP1802 宏的结果

Results from CDP1802 macro

更新不同id但在0.05以内

different id but within 0.05 data

Answer 1

部分回答

我很好奇你会用这个做什么。

我编造了一些类似的出现数据，并在单独的工作表上构建了一个矩阵。也许这会让您知道下一步该去哪里，因为我不确定。

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

您几乎肯定需要对其进行调整，但这是一个起点。将来我可能会有类似的需求，所以我对你的最终项目很感兴趣。

Answer 2

将坐标集合分组到字典中，然后循环遍历它们，在单独的函数中计算平均值。

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, c.count)
    ElseIf c.Count = 1 Then
        CalcAvg = Array(x1, y1, z1, 1)
    Else
        CalcAvg = Array(0, 0, 0, c.count)
    End If
End Function

平均近距离 GPS 坐标

Average close GPS coordinates

excel

vba

coordinates

average

部分回答