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

CodePudding user response：

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, n)
    Else
        CalcAvg = Array(0, 0, 0, 0)
    End If

End Function

CodePudding user response：

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.