AK_Beaver
03-14-2017, 10:44 AM
So I'm trying to write a subtest function inside VBA so I can run my code and see where my calculation problems go wrong. Can someone help me out, please. I keep getting a run time error of 13. I'll include my main code and any other code included in the function. All I'm looking for is getting my sub test code working so I can debug my code. Learning VBA but I want to try to get this myself. Thanks Everyone!
My Input:
Xa=
1425.07
Ya=
7484.80
Bearing-AP=
N 76-04-24 E
Xb=
1971.28
Yb=
5209.64
Bearing-BP=
S 38-29-44 E
Xp=
Excel Output
Yp=
Excel Output
Code Included:
Function DASH2DD(strDashAngle As String) As Double
'Converts DMS angles in dash format to decimal degrees
'Written by Evan Venechuk
'1/26/2017
Dim dDash1 As Double
Dim dDash2 As Double
Dim dDegree As Double
Dim dMinute As Double
Dim dSecond As Double
'Find position of dashes
dDash1 = WorksheetFunction.Find("-", strDashAngle)
dDash2 = WorksheetFunction.Find("-", strDashAngle, dDash1 + 1)
'Parse DMS
dDegree = Left(strDashAngle, dDash1 - 1)
dMinute = Mid(strDashAngle, dDash1 + 1, dDash2 - dDash1 - 1)
dSecond = Right(strDashAngle, Len(strDashAngle) - dDash2)
'Convert to DD and return value
DASH2DD = dDegree + dMinute / 60 + dSecond / 3600
End Function
Function B2Az(strBearing As String) As String
'Converts Bearings to Azimuths
'Written by Evan Venechuk
'02/26/2017
Dim strFirstLetter As String, strLastLetter As String, strAzimuth As String, strAngle As String
Dim dAzimuth As Double, dAngle As Double
'Remove any extra spaces in the bearing and makes all letters upper case
strBearing = UCase(Trim(strBearing))
'Finds the first and last letter in the bearing and stores it
strFirstLetter = Left(strBearing, 1)
strLastLetter = Right(strBearing, 1)
'Finds the DMS angle in dash form inside the bearing and converts it to DD angle
strAzimuth = Mid(strBearing, 3, Len(strBearing) - 4)
dAzimuth = DASH2DD(strAzimuth)
'Converts bearing to azimuth and converts DD angles back into DMS angles in dash form
'Returns Value
If strFirstLetter = "N" And strLastLetter = "E" Then
B2Az = DD2DASH(dAzimuth)
ElseIf strFirstLetter = "S" And strLastLetter = "E" Then
B2Az = DD2DASH(180 - dAzimuth)
ElseIf strFirstLetter = "S" And strLastLetter = "W" Then
B2Az = DD2DASH(180 + dAzimuth)
ElseIf strFirstLetter = "N" And strLastLetter = "W" Then
B2Az = DD2DASH(360 - dAzimuth)
End If
End Function
Main Code:
Function BBI(Range1 As Range, Range2 As Range) As Variant
Dim dXp As Double, dYp As Double, dXa As Double, dXb As Double, dAzAP As Double, dAzBP As Double
Dim dLengthAB As Double, dAzAB As Double, dYa As Double, dYb As Double, dDeltaX As Double, dDeltaY As Double
Dim dAngleA As Double, dAngleB As Double, dAngleP As Double, dlengthAP As Double
dXa = Range1.Item(1)
dYa = Range1.Item(2)
dAzAP = DASH2DD(B2Az(Range1.Item(3)))
dXb = Range2.Item(1)
dYb = Range2.Item(2)
dAzBP = DASH2DD(B2Az(Range2.Item(3)))
dDeltaX = dXb - dXa
dDeltaY = dYb - dYa
dLengthAB = (dDeltaX ^ 2 + dDeltaY ^ 2) ^ 0.5
dAzAB = WorksheetFunction.Degrees(Atn(dDeltaX / dDeltaY))
dAngleB = (180 + dAzAB) - dAzBP
dAngleP = 180 - dAngleA - dAngleB
dAngleB = WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleB)))
dAngleP = WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleP)))
dlengthAP = dLengthAB * (dAngleB / dAngleP)
dXp = dXa + dlengthAP * WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleA)))
dYp = dYa + dlengthAP * WorksheetFunction.Degrees(Cos(WorksheetFunction.Radians(dAngleA)))
BBI = WorksheetFunction.Transpose(Array(dXp, dYp))
End Function
SubTest:
Sub test_BBI()
Dim RangeOne As Range, RangeTwo As Range
Sheets("Problem 3").Activate
Set RangeOne = Range("G3:G5")
Set RangeTwo = Range("G7:G9")
Debug.Print BBI(RangeOne, RangeTwo)
End Sub
My Input:
Xa=
1425.07
Ya=
7484.80
Bearing-AP=
N 76-04-24 E
Xb=
1971.28
Yb=
5209.64
Bearing-BP=
S 38-29-44 E
Xp=
Excel Output
Yp=
Excel Output
Code Included:
Function DASH2DD(strDashAngle As String) As Double
'Converts DMS angles in dash format to decimal degrees
'Written by Evan Venechuk
'1/26/2017
Dim dDash1 As Double
Dim dDash2 As Double
Dim dDegree As Double
Dim dMinute As Double
Dim dSecond As Double
'Find position of dashes
dDash1 = WorksheetFunction.Find("-", strDashAngle)
dDash2 = WorksheetFunction.Find("-", strDashAngle, dDash1 + 1)
'Parse DMS
dDegree = Left(strDashAngle, dDash1 - 1)
dMinute = Mid(strDashAngle, dDash1 + 1, dDash2 - dDash1 - 1)
dSecond = Right(strDashAngle, Len(strDashAngle) - dDash2)
'Convert to DD and return value
DASH2DD = dDegree + dMinute / 60 + dSecond / 3600
End Function
Function B2Az(strBearing As String) As String
'Converts Bearings to Azimuths
'Written by Evan Venechuk
'02/26/2017
Dim strFirstLetter As String, strLastLetter As String, strAzimuth As String, strAngle As String
Dim dAzimuth As Double, dAngle As Double
'Remove any extra spaces in the bearing and makes all letters upper case
strBearing = UCase(Trim(strBearing))
'Finds the first and last letter in the bearing and stores it
strFirstLetter = Left(strBearing, 1)
strLastLetter = Right(strBearing, 1)
'Finds the DMS angle in dash form inside the bearing and converts it to DD angle
strAzimuth = Mid(strBearing, 3, Len(strBearing) - 4)
dAzimuth = DASH2DD(strAzimuth)
'Converts bearing to azimuth and converts DD angles back into DMS angles in dash form
'Returns Value
If strFirstLetter = "N" And strLastLetter = "E" Then
B2Az = DD2DASH(dAzimuth)
ElseIf strFirstLetter = "S" And strLastLetter = "E" Then
B2Az = DD2DASH(180 - dAzimuth)
ElseIf strFirstLetter = "S" And strLastLetter = "W" Then
B2Az = DD2DASH(180 + dAzimuth)
ElseIf strFirstLetter = "N" And strLastLetter = "W" Then
B2Az = DD2DASH(360 - dAzimuth)
End If
End Function
Main Code:
Function BBI(Range1 As Range, Range2 As Range) As Variant
Dim dXp As Double, dYp As Double, dXa As Double, dXb As Double, dAzAP As Double, dAzBP As Double
Dim dLengthAB As Double, dAzAB As Double, dYa As Double, dYb As Double, dDeltaX As Double, dDeltaY As Double
Dim dAngleA As Double, dAngleB As Double, dAngleP As Double, dlengthAP As Double
dXa = Range1.Item(1)
dYa = Range1.Item(2)
dAzAP = DASH2DD(B2Az(Range1.Item(3)))
dXb = Range2.Item(1)
dYb = Range2.Item(2)
dAzBP = DASH2DD(B2Az(Range2.Item(3)))
dDeltaX = dXb - dXa
dDeltaY = dYb - dYa
dLengthAB = (dDeltaX ^ 2 + dDeltaY ^ 2) ^ 0.5
dAzAB = WorksheetFunction.Degrees(Atn(dDeltaX / dDeltaY))
dAngleB = (180 + dAzAB) - dAzBP
dAngleP = 180 - dAngleA - dAngleB
dAngleB = WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleB)))
dAngleP = WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleP)))
dlengthAP = dLengthAB * (dAngleB / dAngleP)
dXp = dXa + dlengthAP * WorksheetFunction.Degrees(Sin(WorksheetFunction.Radians(dAngleA)))
dYp = dYa + dlengthAP * WorksheetFunction.Degrees(Cos(WorksheetFunction.Radians(dAngleA)))
BBI = WorksheetFunction.Transpose(Array(dXp, dYp))
End Function
SubTest:
Sub test_BBI()
Dim RangeOne As Range, RangeTwo As Range
Sheets("Problem 3").Activate
Set RangeOne = Range("G3:G5")
Set RangeTwo = Range("G7:G9")
Debug.Print BBI(RangeOne, RangeTwo)
End Sub