Finding Angular Misclosure and then Balancing Angles

So in my land surveying computations class we were asked to create a code that would find the angular misclosure between a set of angles (i.e. if a polygon has three sides the sum of angles should be 180, angular misclosure is whats the difference) and once we find that we need to distribute the error to the angles so that the balanced sum is what it should be (i.e. distribute error so that the angles do actually equal 180). Sorry for the long winded sentence. We are doing this because we are creating codes that once all completed we will be able to calculate a survey traverse. So far I'm doing them on my own but this one I'm completely stumped. My professor lost me and even he is lost. Awesome - I know, right. If anyone can make sense and give me suggestions or even finish it, I'll take either, and be forever thankful. Here's what I have and I'll include other code in it that I've finished and ran. Thanks again.

Code:

---

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

---

Code:

---

Function DD2DASH(dDDAngle As Double) As String

'Converts DD angles to DMS angles in dash format
'Written by Evan Venechuk
'1/31/2017

Dim dDegrees As Double
Dim dMinutes As Double
Dim dSeconds As Double

'Find Degrees

dDegrees = Int(dDDAngle)

'Find Minutes

dMinutes = (dDDAngle - dDegrees) * 60

'Find Seconds

dSeconds = (dMinutes - Int(dMinutes)) * 60

'Convert to DMS in dash form and return value

DD2DASH = Format(dDegrees, "00") & "-" & Format(Int(dMinutes), "00") & "-" & Format(dSeconds, "00")

End Function

---

The Code I have Trouble With:

Code:

---

Function AngMisclosure(InRange As Range) As String

Dim mycell As Range
Dim strAngle As String
Dim dAngle, dSum, dNumAng, dSumTheory, dMisc, dOneSec As Double
Dim iMyIndex As Integer

dSum = 0

For Each mycell In InRange
    strAngle = mycell.Value
    dAngle = DASH2DD(strAngle)
    dSum = dSum + dAngle

Next mycell
'-------------------------------------
dNumAng = InRange.Count
dSumTheory = (dNumAng - 2) * 180

dMisc = dSum - dSumTheory

'AngMisclosure = DD2DASH(dMisc)
'-------------------------------------
dOneSec = 1# / 3600#

iMyIndex = 1

Do While dMisc > 0#

    InRange.Item(iMyIndex) = InRange.Item(iMyIndex) - 1
    iMyIndex = iMyIndex + 1
   
    If iMyIndex > dNumAng Then
        iMyIndex = 1
    End If
Loop

End Function

---

http://www.dot.ca.gov/hq/row/landsurveys/LSITWorkbook/05.pdf

https://engineering.purdue.edu/~asm2.../travcalc.html

You actually have two issues: 1) Inputs and Outputs are in Dash Format; 2) All math must be performed in Decimal Format.

Code:

---

'Dim all the others
Dim Angle As Double
Dim Angles as Variant
'
'Set OutRange Range
'
Redim Angles(1 to dNumAng)

'Add Decimal Angles to Angles array And get Sum of all Angles
For i = 1 to dNumAng
Angle = Dash2DD(InRange(i))
DSum = Dsum + Angle
Angles(i) = Angle
Next

dMisc = dSum - ((dNumAng - 2) * 180)

'Write corrected Angles in Dash Format
For i - Lbound(Angles) to UBound(Angles)
OutRange(i) = DD2Dash(Angles(i) + DMisc * Angles(i) / DSum)
Next

---

Note: I used Proportionalities for the corrections, You might should use Average as per the second link above :dunno: Perfect is impossible, choose the 'Good Enuff' that pleases you. Another choice is to use the Theoretical vice DSum for Proportionalities.

Alternatives

Code:

---

    dDash1 = InStr(strDashAngle, "-")
    dDash2 = InStrRev(strDashAngle, "-")

---

I know how to do it by hand - no problem. I need help coding it.

Yer 2 fast fer me. Reread my edited post.

If that ain't right, tell us step by step, leaving no steps out, how to do it by hand.

Ever thang I no 'bout sirvays, I larnt from them thar 2 links

I keep getting a run time error of 9. Is this what the full code should look like? Thanks for your help so far - I appreciate it. It's midnight in Alaska but I'll get a better explanation to what I'm trying to do and post it. Thanks again

Code:

---

Function AngMis(InRange As Range) As String

'Dim all the others
Dim dMisc, dSum, dNumAng, dAngle As Double
Dim Angles As Variant
Dim iIndex1 As Integer
Dim OutRange As Range

 'Set OutRange Range

ReDim Angles(1 To dNumAng)

 'Add Decimal Angles to Angles array And get Sum of all Angles

For iIndex1 = 1 To dNumAng
    dAngle = DASH2DD(InRange(iIndex1))
    dSum = dSum + dAngle
    Angles(iIndex1) = dAngle
Next
 
dMisc = dSum - ((dNumAng - 2) * 180)
 
 'Write corrected Angles in Dash Format

For iIndex1 = LBound(Angles) To UBound(Angles)
    OutRange(iIndex1) = DD2DASH(Angles(iIndex1) + dMisc * Angles(iIndex1) / dSum)
Next

End Function

---

Here's the test function I wrote to check it inside the module too. My test angles inside cells A1 to A3 are 60-24-15, 80-25-40, and 39-10-30. When I run the code in the spreadsheet I just get 0 returned. I'm still lost.

Code:

---

Sub test_AngMisc()

Dim MyRange As Range

Sheets("Sheet1").Activate

Set MyRange = Range("A1:A3")

Debug.Print AngMis(MyRange)

End Sub

---

Sorry I wasn't clear enough

You need to dim all the others and you need to set the output range and you need to add the bits from your original code that complete the part I wrote at bedtime last night.

Put this Sub and your two conversion functions in a Standard Module. Select Range A1:A3 on Sheet1 then Run the Excel Macro Menu item "CorrectAngMis."

Code:

---

sub CorrectAngMis()
   
    'Dim all the others
    Dim dMisc as Double, dSum as Double, dNumAng as Double, dAngle As Double
    Dim Angles As Variant
    Dim iIndex1 As Long
    Dim OutRange As Range
   
Set InRange = Selection
'Set OutRange next to InRange
 set OutRange = InRange.Offset(, 1)
 
 dNumAng = InRange.Count 
ReDim Angles(1 To dNumAng)
   
    'Add Decimal Angles to Angles array And get Sum of all Angles
   
    For iIndex1 = 1 To dNumAng
        dAngle = DASH2DD(InRange(iIndex1))
        dSum = dSum + dAngle
        Angles(iIndex1) = dAngle
    Next
   
    dMisc = dSum - ((dNumAng - 2) * 180)
   
    'Write corrected Angles in Dash Format
   
    For iIndex1 = LBound(Angles) To UBound(Angles)
        OutRange(iIndex1) = DD2DASH(Angles(iIndex1) + dMisc * Angles(iIndex1) / dSum)
    Next
   
 end sub

---

If you just want a Function that returns AngMis so that you can manually apply the corrections

Code:

---

Function AngMis(InRange As Range) As String
Dim DSum As Double
Dim i As Long

For i = 1 to InRange.Count
DSum = Dsum + DASH2DD(InRange(i))
Next

AngMis = DD2Dash(dSum - (InRange.Count - 2) * 180)
End Function

---

FYI:
A Function must be internally set to a value in order to return the value.

There are very few conventions that apply across all programing languages; the use of "i", "j", and "k" as counters and indexers is one of them.

In VBA for Excel, when counting or indexing Rows and Columns, Always declare the Counter/Indexer as a Long Type. While the Integer Type will work in many cases, it is a best practice to make it a habit to use Longs, so you don't get the dreaded "Index Out of bounds" error.

In VBA for Excel, I often use "r", "c", and "s" as indices for Rows, Columns, and Sheets. YMMV

In VBA, when declaring many variables on one line, any that are not specifically Typed, (as I did above,) are auto-Typed as Variants. In fact any variable not specifically Typed are auto-Typed as Variants

Code:

---

Dim Angles

---

ps: I did not open Excel for any of the code I wrote in this thread. Consider any errors as practice troubleshooting :devil2:

I'm confused by why it has to be a function. Actually I'm confused by a lot of things here and I guessed at the apportionment algorithm was and made it the average

This Sub takes a range of inputs in DASH format and puts the adjusted angles back to the WS in another range


Attachment 18536

Code:

---

Option Explicit

Sub drv()
    AngMis Range("A2:A4"), Range("B2:B4")
End Sub

Sub AngMis(InRange As Range, OutRange As Range)
   
    'Dim all the others
    Dim dMisc As Double
    Dim i As Integer
    Dim aDD() As Double
   
    'Add Decimal Angles to Angles array And get Sum of all Angles
   
    ReDim aDD(1 To InRange.Rows.Count)
    For i = 1 To InRange.Rows.Count
        aDD(i) = DASH2DD(InRange.Cells(i, 1).Value)
    Next
   
    dMisc = 180# - Application.WorksheetFunction.Sum(aDD)
   
    'Write corrected Angles in Dash Format
    For i = 1 To OutRange.Rows.Count
        OutRange.Cells(i, 1).Value = DD2DASH(aDD(i) + dMisc / UBound(aDD))
    Next
End Sub

---

Just some ideas FWIW