Average close GPS coordinates

Question

im working on a macro to average all GPS coordinates that fall within a specified distance. I cant think of a way to loop through the list of coordinates to check if any of the other coordinates in the list are within 0.05 then average the coordinate.

I have played around using if statements and the distance between two coordinates formula

JoinD = Abs(((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2) ^ 0.5)
matchdist=0.05    
If JoinD < matchdist Then..

Update: I have been tinkering around with the following logic and I think im on the right track

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

Then after that have some logic that divides each sumX/sumy/sumZ value by the number of matches

But I cannot get anything working. the ideal result would be turning this data

unaveraged coords

into this data

averaged coords

Results from CDP1802 macro

Results from CDP1802 macro

Update for different id but within 0.05

different id but within 0.05 data

Answer 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