Macro Distance between points

[stanysurfer]

Hey guys, somewhat of a noob at vba and need a little help with a small problem...
I have a series of points with x and y co-ordinates and I need to find the distance between all of the points and each other. The number of points will change and this needs to be taken into account in the vba code. I tried using an next statement with a loop, but really struggling. Also it is subject to the following formula:

gh = C0 + C * [1.5(h/a)-0.5*(h/a)^3] for h<a..
gh = C0 + C h>a
gh = o h = 0

Where gh "gamma h" is what i ultimately need to work out, after working out h, Co and C are values given, h is the distance between the points, which will need to be put in the formula and a is a given number (a distance). So a simple if statement could suffice for these equations depending on what the distance between points are..
For example if there are 4 points, the matrix will be 4 x 4 with 16 values of gh...

Any help at all would be greatly appreciated.
Thank you

 

[stanysurfer]

Hey guys I also had a post on a different site for some other points of views, didnt realise this was a bad thing to do, as i am new to all this. The link is as follows:
http://www.excelforum.com/excel-programming/743691-distance-between-points-to-matrix-form.html

I am still trying to work out a solution, I will make both aware if I do. Thank yo kindly.

 

[bobsan42]

well i found the time to test it.
i made it work now - will post it in a few minutes

 

[bobsan42]

tested now - should have no problems.
2 ways of using it:
1st way: insert as an array formula (not very convenient)
select a range in the sheet with the dimensions of the matrix you need - then enter the formula with Ctrl+Shift+Enter

2nd way: use a ready made macro
before doing this - put the macro and the function (posted below) in a module in the workbook.
X coords go in column A starting from A1
Y coords go in column B starting from B1
cell C1 - parameter A
cell C2 - parameter C
cell C3 - parameter C0
select a cell in column D or right-er
run the macro with the stupid name

Sub testmenkasjdn()
    Dim arrrrrtdt As Variant
    lr1 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    arrrrrtdt = matrix_gh(ActiveSheet.Range("C1"), ActiveSheet.Range("C2"), ActiveSheet.Range("C3"), ActiveSheet.Range("A1:A" & lr1), ActiveSheet.Range("B1:B" & lr1))
    Debug.Print LBound(arrrrrtdt, 1); UBound(arrrrrtdt, 1), LBound(arrrrrtdt, 2); UBound(arrrrrtdt, 2)
    ActiveCell.Resize(UBound(arrrrrtdt, 1), UBound(arrrrrtdt, 2)) = arrrrrtdt
End Sub

Function matrix_gh(param_A As Double, param_C As Double, param_C0 As Double, coordX As Range, coordY As Range) As Variant

Dim i As Long, j As Long, Nijk As Long
Dim arr_h() As Double, arr_gh() As Double

If coordX.Rows.Count <> 1 And coordX.Columns.Count <> 1 Then GoTo ExitOnDataError
If coordY.Rows.Count <> 1 And coordY.Columns.Count <> 1 Then GoTo ExitOnDataError
If coordX.Cells.Count <> coordY.Cells.Count Then GoTo ExitOnDataError

Nijk = coordX.Cells.Count

Dim arr_X() As Variant, arr_Y() As Variant
ReDim arr_h(1 To Nijk, 1 To Nijk)
ReDim arr_gh(1 To Nijk, 1 To Nijk)
arr_X = coordX.Value
arr_Y = coordY.Value

For i = 1 To Nijk
    For j = 1 To Nijk
        arr_h(i, j) = Sqr((arr_X(j, 1) - arr_X(i, 1)) ^ 2 + (arr_Y(j, 1) - arr_Y(i, 1)) ^ 2)
        Select Case arr_h(i, j)
        Case Is > param_A
            arr_gh(i, j) = param_C0 + param_C
        Case 0
            arr_gh(i, j) = 0
        Case Else
            arr_gh(i, j) = param_C0 + param_C * (1.5 * (arr_h(i, j) / param_A) - 0.5 * (arr_h(i, j) / param_A) ^ 3)
        End Select
    Next j
Next i
matrix_gh = arr_gh()

Exit Function

ExitOnDataError:
matrix_gh = "#VALUE!"
Exit Function

End Function

hope it will work for you now
probably a lot of improvements can be made but have no time for this - maybe someone else.
good luck

 

[mikerickson]

This might work. The location of data in the first section of CalcGammaDistances should be adjusted.
This has x values in column A, y in Column B. with C, C0 and a in the indicated cells.

Type Cartisian
    x As Double
    y As Double
End Type

Sub CalcGammaDistances()
    Dim xValues As Variant
    Dim yValues As Variant
    Dim C As Double, C0 As Double, a As Double
    Dim destinationrange As Range
    Dim Points() As Cartisian, strPoints() As String
    Dim gammaD() As Double
    Dim pointsCount As Long
    Dim i As Long, j As Long
    
    With ThisWorkbook.Sheets("SHeet1")
        With Range("A:A"): Rem adjust
            xValues = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
        End With
        With Range("B:B"): Rem adjust
            yValues = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
        End With
        C = .Range("D1")
        C0 = .Range("D2")
        a = .Range("D3")
        Set destinationrange = .Range("F1")
    End With
    
    pointsCount = UBound(xValues, 1)
    ReDim Points(1 To pointsCount)
    ReDim strPoints(1 To pointsCount)
    For i = 1 To pointsCount
        With Points(i)
            .x = xValues(i, 1)
            .y = yValues(i, 1)
        End With
        strPoints(i) = CartStr(Points(i))
    Next i
    
    ReDim gammaD(1 To pointsCount, 1 To pointsCount)
    For i = 1 To pointsCount
        For j = i + 1 To pointsCount
            gammaD(i, j) = GammaDistance(Points(i), Points(j), C, C0, a)
            gammaD(j, i) = GammaDistance(Points(i), Points(j), C, C0, a)
        Next j
    Next i
    With destinationrange
        .Offset(0, 1).Resize(1, pointsCount).Value = strPoints
        .Offset(1, 0).Resize(pointsCount, 1).Value = Application.Transpose(strPoints)
        .Offset(1, 1).Resize(pointsCount, pointsCount).Value = gammaD
    End With
End Sub

Function GammaDistance(aPoint As Cartisian, bPoint As Cartisian, C As Double, C0 As Double, a As Double)
    Dim h As Double
    h = Distance(aPoint, bPoint)
    If h = 0 Then
        GammaDistance = 0
    Else
        If a < h Then
            GammaDistance = C0 + C
        Else
            GammaDistance = C0 + C + (h / a) * (1.5 - 0.5 * (h / a) ^ 2)
        End If
    End If
End Function

Function Distance(aPoint As Cartisian, bPoint As Cartisian) As Double
    Distance = Sqr((aPoint.x - bPoint.x) ^ 2 + (aPoint.y - bPoint.y) ^ 2)
End Function

Function CartStr(aPoint As Cartisian) As String
    With aPoint
        CartStr = "(" & .x & ", " & .y & ")"
    End With
End Function

 

[mikerickson]

You also might use this UDF, which uses the code above, to get the gamma distance of two points without calculating the whole chart.

Function GDistance(x_1 As Double, y_1 As Double, x_2 As Double, y_2 As Double, C As Double, C0 As Double, a As Double) As Double
    Dim pt_1 As Cartisian, pt_2 As Cartisian
    With pt_1
        .x = x_1: .y = y_1
    End With
    With pt_2
        .x = x_2: .y = y_2
    End With
    GDistance = GammaDistance(pt_1, pt_2, C, C0, a)
End Function

 

[stanysurfer]

Thankyou to both of you, this is exactly what i need, I will play around with it a bit, but very very happy. Thank you both so much for your help

 

[stanysurfer]

This might work. The location of data in the first section of CalcGammaDistances should be adjusted.
This has x values in column A, y in Column B. with C, C0 and a in the indicated cells.

Type Cartisian
    x As Double
    y As Double
End Type

Sub CalcGammaDistances()
    Dim xValues As Variant
    Dim yValues As Variant
    Dim C As Double, C0 As Double, a As Double
    Dim destinationrange As Range
    Dim Points() As Cartisian, strPoints() As String
    Dim gammaD() As Double
    Dim pointsCount As Long
    Dim i As Long, j As Long
    
    With ThisWorkbook.Sheets("SHeet1")
        With Range("A:A"): Rem adjust
            xValues = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
        End With
        With Range("B:B"): Rem adjust
            yValues = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
        End With
        C = .Range("D1")
        C0 = .Range("D2")
        a = .Range("D3")
        Set destinationrange = .Range("F1")
    End With
    
    pointsCount = UBound(xValues, 1)
    ReDim Points(1 To pointsCount)
    ReDim strPoints(1 To pointsCount)
    For i = 1 To pointsCount
        With Points(i)
            .x = xValues(i, 1)
            .y = yValues(i, 1)
        End With
        strPoints(i) = CartStr(Points(i))
    Next i
    
    ReDim gammaD(1 To pointsCount, 1 To pointsCount)
    For i = 1 To pointsCount
        For j = i + 1 To pointsCount
            gammaD(i, j) = GammaDistance(Points(i), Points(j), C, C0, a)
            gammaD(j, i) = GammaDistance(Points(i), Points(j), C, C0, a)
        Next j
    Next i
    With destinationrange
        .Offset(0, 1).Resize(1, pointsCount).Value = strPoints
        .Offset(1, 0).Resize(pointsCount, 1).Value = Application.Transpose(strPoints)
        .Offset(1, 1).Resize(pointsCount, pointsCount).Value = gammaD
    End With
End Sub

Function GammaDistance(aPoint As Cartisian, bPoint As Cartisian, C As Double, C0 As Double, a As Double)
    Dim h As Double
    h = Distance(aPoint, bPoint)
    If h = 0 Then
        GammaDistance = 0
    Else
        If a < h Then
            GammaDistance = C0 + C
        Else
            GammaDistance = C0 + C + (h / a) * (1.5 - 0.5 * (h / a) ^ 2)
        End If
    End If
End Function

Function Distance(aPoint As Cartisian, bPoint As Cartisian) As Double
    Distance = Sqr((aPoint.x - bPoint.x) ^ 2 + (aPoint.y - bPoint.y) ^ 2)
End Function

Function CartStr(aPoint As Cartisian) As String
    With aPoint
        CartStr = "(" & .x & ", " & .y & ")"
    End With
End Function

This works well, Is there a way of internally calculating the average gammadistance value for all the gammadistances, instead of say plotting all the numbers in a matrix form on the worksheet and then finding the average..
What I need to do instead is calculate the averagegamma distance for all the points and just display that one value..
An example being, if u use the code above, with four points namely x1 = 10, y1=40 x2=100, y2=60, then run the macro you should get a 2 x 2 matrix with four values for gammadistance, then you can just take the average of them and the answer is 3.07.
All i need is that one value, can this be calculated in the above code??

Thank you all so much

Cheers