Average close GPS coordinates

Solution 1:

Group collections of co-ordinates into a dictionary and then loop though them calculating the average in a separate function.

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

Solution 2:

Partial answer

I'm curious where you go with this.

I made up some similar appearing data and built a matrix on a separate worksheet. Maybe this gives you an idea where to go next, as I am not sure.

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

You'll almost certainly need to adjust that, but it's a starting point. It's a possibility that I will have a similar need in the future for something like this, so I'm interested in whatever your final project looks like.