VBA处理DINI03水准路线（bf）+中间点

Sub 计算中间点()
Dim A As Double
Dim i, R As Integer
Dim H As String

Range("g1:g100").Offset(0, 1).Insert
Range("h1:h100").Offset(0, 1).Insert
Range("i1:i100").Offset(0, 1).Insert
For i = 1 To 100

If Cells(i, 13) = "Rb" And Cells(i + 1, 13) = "Rf" Then
A = Cells(i, 14)
R = Cells(i, 17)
H = Cells(i, 7)

Cells(i + 1, 8) = Cells(i + 1, 7)
Cells(i + 1, 7) = H
Cells(i + 1, 9) = Round(Cells(i, 14) - Cells(i + 1, 14), 7)
Cells(i + 1, 10) = Round((Cells(i, 17) + Cells(i + 1, 17)) / 1000, 3)
Cells(i + 1, 7) = Cells(i, 7)
ElseIf Cells(i, 13) = "Rz" Then

Cells(i, 8) = Cells(i, 7)
Cells(i, 7) = H
Cells(i, 9) = Round(A - Cells(i, 14), 7)
Cells(i, 10) = Round((R + Cells(i, 17)) / 1000, 3)

ElseIf Cells(i, 6) = "End" Or Cells(i, 6) = "Intermediate" Then Cells(i, 9) = ""
Cells(i, 10) = ""

End If
Next
End Sub
Sub 生成IN1()

Sheet2.Range("a1:d86").Value = Sheet1.Range("G1:J86").Value
Sheet2.Range("e1:e86").Value = "1"

   
End Sub
Sub 输出IN1()

   
Dim j As Long
 

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

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

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

    End If
 

    Next                             '检测下一个
    
     Dim s As String

    Dim FullName As String, rng As Range

    Application.ScreenUpdating = False

     FullName = (ActiveSheet.Name & ".IN1")   '以当前表名为TXT文件名

 '   FullName = Replace(ThisWorkbook.FullName, ".xls", ".txt")  '以当前文件名为TXT文件名

 '   FullName = Replace(ThisWorkbook.FullName, ".xls", ActiveSheet.Name & ".txt")  '以文件名&表名为TXT文件名

    Open FullName For Output As #1    '以读写方式打开文件，每次写内容都会覆盖原先的内容

    '参考帮助，fullname为文件全名

    For Each rng In Sheet2.Range("a1").CurrentRegion

        s = s & IIf(s = "", "", ",") & rng.Value

        If rng.Column = Sheet2.Range("a1").CurrentRegion.Columns.Count Then

            Print #1, s & " "   '把数据写到文本文件里

            s = ""
'          Else
'
'          Print #1, s & ""   '把数据写到文本文件里
'
'            s = ""
        End If

    Next

    Close #1    '关闭文件

    Application.ScreenUpdating = True

    MsgBox "数据已导入文本"
End Sub