全站仪角度定向，极坐标解算

Sub 导入全站仪数据()
    Dim Filename As Variant, myText, S, mArr() As String, narr() As String
    Dim i, y As Long, j As Long
    Filename = ThisWorkbook.Path & "\1112X.GT7"      '指定文件字符串
    j = 1
    With Worksheets("sheet1")
        .Cells.ClearContents
        Open Filename For Input As #1
        Do While Not EOF(1)
            
        Line Input #1, myText    ' 读入一行数据并将其赋予某变量
        S = Replace(myText, "   ", ",")
            mArr = Split(S, ",")    '按逗号分开这个字符，循环赋值给单元格
          
          
            
    
            For i = 0 To UBound(mArr)
                .Cells(j, i + 1) = mArr(i)
            Next i
            j = j + 1
        Loop
        Close #1    ' 关闭文件。
    End With
    End Sub

Sub 编码分列()
Dim i As Integer

For i = 2 To 255

 If IsNumeric(Cells(i, 4)) Then
Cells(i, 6) = ""
Else

Cells(i, 6) = Cells(i, 4) & Cells(i, 2)

End If

 If Cells(i, 1) = "STN" Then

Cells(i + 1, 6) = Cells(i + 1, 2) '后视点
Cells(i, 6) = Cells(i, 2)   '测站点名
i = i + 1
End If
Range("F1:F200").HorizontalAlignment = Excel.xlLeft
Next

End Sub

 Sub 导入控制点()
    Dim Filename As Variant, myText, mArr() As String
    Dim i As Long, j As Long
    Filename = ThisWorkbook.Path & "\kz.txt"      '指定文件字符串
    j = 1
    With Worksheets("sheet1")

        Open Filename For Input As #1
        Do While Not EOF(1)
            Line Input #1, myText    ' 读入一行数据并将其赋予某变量
            mArr = Split(myText, ",")    '按逗号分开这个字符，循环赋值给单元格

            For i = 0 To UBound(mArr)
                .Cells(j, i + 10) = mArr(i)
            Next i
            j = j + 1
        Loop
        Close #1    ' 关闭文件。
    End With
End Sub
Sub 导入控制点2()

Dim i, y As Integer

For y = 1 To 20
 

For i = 1 To 200
If Cells(i, 6) = Cells(y, 10) Then
Cells(i, 7) = Cells(y, 11)
Cells(i, 8) = Cells(y, 12)
Cells(i, 9) = Cells(y, 13)
 
End If
Next

Next
End Sub

Sub 坐标高程计算()
Dim i, C, D, F, M As Integer, W, H, Z, T, j, S, G As Double
Dim PI As Double
PI = 3.14159265258979
i = 2
For C = 1 To 256
If Cells(C, 1) = "STN" Then
W = Application.Atan2((Cells(C + 1, 7) - Cells(C, 7)), (Cells(C + 1, 8) - Cells(C, 8)))
 If W < 0 Then
W = W + 2 * PI
 End If

  
 Do
i = i + 1
If Cells(i, 1) = "SD" Then
 
 D = Int(Cells(i, 2))
 F = Int((Cells(i, 2) - D) * 100)
 M = (Cells(i, 2) - D) * 10000 - F * 100
 H = D * PI / 180 + F * PI / 180 / 60 + M * PI / 180 / 60 / 60 + W

 
 If H > 2 * PI Then
H = H - 2 * PI
 End If
Z = 90 - Cells(i, 3)
T = Int(Z)
If T < 0 Then
T = Int(Z * -1)
End If
j = Int((Z - T) * 100)
If j < 0 Then

j = Int((Z - T) * -1 * 100)
End If
S = Z * 10000 - j * 100
If S < 0 Then
S = Z * 10000 * -1 - j * 100
End If

G = T * PI / 180 + j * PI / 180 / 60 + S * PI / 180 / 60 / 60
 If Z < 0 Then
 G = G * -1
 End If
 Cells(i - 1, 7) = Round(Cells(i, 4) * Cos(H) + Cells(C, 7), 3)
Cells(i - 1, 8) = Round(Cells(i, 4) * Sin(H) + Cells(C, 8), 3)
Cells(i - 1, 9) = Round(Cells(i, 4) * Sin(G) - Cells(i - 1, 3) + Cells(C, 3) + Cells(C, 9), 3)
 
   
 
  End If
   
  Loop Until Cells(i, 1) = "STN"
 
End If
Next
End Sub

Sub 另存为excel()
Dim j As Long
 Sheet2.Range("a1:d1000") = Sheet1.Range("f1:i1000").Value

    For j = Sheet2.Cells(1048576, 2).End(xlUp).Row To 1 Step -1
 

    If Sheet2.Cells(j, 1) = "" Then           '如果单元格为空白
 

    Sheet2.Cells(j, 1).EntireRow.Delete          '符合条件的都删除整行
 

    End If
 

    Next                             '检测下一个

Sheet2.Copy
ActiveWorkbook.SaveAs Filename:="d:\备份.xls "  '修改保存文件目录
End Sub