Hallo, ich möchte verschiedene Datenpunkte aus Excel auslesen und die Entfernungen zwischen ihnen berechnen und wieder ausgeben. Hier mein bisheriger Ansatz:
Public Function get_Distance(x1, x2, y1, y2)
'Distanzfunktion zur Bestimmung des Abstandes zwischen zwei Punkten
get_Distance = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
End Function
Private Sub CommandButton1_Click()
Dim L As Long
Dim T As Long
Dim d As Double 'distance
Dim Laenge As Long
Laenge = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:B" & Laenge)
ReDim arrTmp(1 To UBound(arr), 1 To UBound(arr)) 'Abstandsarray
ReDim Min(1 To UBound(arr), 1 To 2) 'Minimaler Abstand jedes Punktes
Range("K1:P1000").ClearContents 'Output
For L = 1 To UBound(arr) 'Distanz berechnen und in arrTmp speichern
For T = 1 To UBound(arr)
d = get_Distance(arr(L, 1), arr(T, 1), arr(L, 2), arr(T, 2))
arrTmp(L, T) = d
ActiveSheet.Cells(L + 1, T + 10) = arrTmp(L, T) 'Output
'Find Minimum
If L = 1 Then 'Erste Zeile jeder Spalte als temporäres Minimum
Min(T, 1) = arrTmp(1, T)
End If
If L <> T Then
If arrTmp(L, T) < Min(T, 1) Then 'Finden des minimalen Abstands jeder Spalte
Min(T, 1) = arrTmp(L, T)
Min(T, 2) = L
Exit For
End If
End If
ActiveSheet.Cells(T + 1, 19) = Min(T, 1)
Next T
Next L
End Sub
Wenn ich mir im 1. Teil die Distanzen für alle Punkte berechnen lasse, in arrTmp speichere und dann in Excel ausgebe, gibt es merkwürdige Lücken, wie man hier sehen kann:
https://imgur.com/a/zlQlNcD
Anscheinend berechnet die Funktion get_Distance nicht alle Distanzen, wodurch in arrTmp leere Stellen entstehen. Ich kann mir aber nicht erklären, warum das so ist. Über Hilfe dazu würde ich mich sehr freuen.
Der 2. Teil nach dem Kommentar "find minimum" soll aus den einzelnen Distanzen die jeweils kleinste für jeden Punkt finden und funktioniert glaube ich ganz gut.
Gruß Damian
|