求分析代码，mdb批量导分类出到xls

sunqv

数据库中的内容要求根据图幅号导出生成新的以图幅号命名xls，单个xls的sheet要求以管类命名sheet，代码见附件
问题：为什么这样导出的单元格中，起点号和终点号会有重复的数值出现？


*******************分界线******************
Sub subDC()
Dim rsTH As DAO.Recordset
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim objxls As Object
Dim objxls1 As Object
Dim objxls2 As Object
Dim N As Long
Dim I As Long
Dim J As Long
Dim Sheet As String
Dim strGZ As String
Dim lngTSales As Long
Dim lngTSTock As Long

Set rsTH = CurrentDb.OpenRecordset("SELECT 所在图幅 FROM line2 GROUP BY 所在图幅 ORDER BY 所在图幅 DESC")
rsTH.MoveNext
rsTH.MoveFirst
For N = 1 To rsTH.RecordCount
    Set objxls = CreateObject("excel.Application")
    objxls.Workbooks.Open FileName:= _
        "C:\Users\Administrator.USER-20180502UW\Desktop\导出文件夹\模板-深圳.xls"
    objxls.Visible = True
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM line2 WHERE 所在图幅='" & rsTH("所在图幅") & "' ORDER BY 所在图幅 DESC, 起点号")
    rs.MoveFirst
    Do While rs.EOF = False
        Sheet = DH(Left(rs("起点号"), 2))
        With objxls
            If strGZ <> Sheet Then
                I = 0
            End If
            .Sheets(Sheet).Select
            .Range("A" & I + 3) = rs("起点号")
            .Range("H" & I + 3) = rs("X坐标")
            .Range("I" & I + 3) = rs("Y坐标")
            .Range("F" & I + 3) = rs("特征")
            .Range("G" & I + 3) = rs("附属物")
            .Range("J" & I + 3) = rs("地面高程")
            Set rs1 = CurrentDb.OpenRecordset("SELECT * FROM line2 ORDER BY 起点号")
            rs1.FindFirst "起点号='" & rs("起点号") & "' OR 终点号='" & rs("起点号") & "'"
            If rs1.NoMatch = False Then
                .Range("B" & I + 3) = rs1("终点号")
                .Range("C" & I + 3) = rs1("埋设方式")
                .Range("D" & I + 3) = rs1("材质")
                .Range("E" & I + 3) = rs1("管径")
              If Sheet = "电力" Then
                    .Range("O" & I + 3) = rs1("电压")
                End If
                .Range("M" & I + 3) = rs1("起点深")
                .Range("N" & I + 3) = rs1("总孔数") & "/" & rs1("已用孔数")
               If rs1("埋设方式") = "方沟" Then
                    .Range("L" & I + 3) = rs1("起点高程")
                  Else
                    .Range("K" & I + 3) = rs1("起点高程")
                End If
            I = I + 1
           End If
        End With
    rs.MoveNext
    strGZ = Sheet
Loop
objxls.ActiveWorkbook.SaveAs FileName:=CurrentProject.Path & "\" & rsTH("所在图幅") & ".xls"
Set objxls = Nothing

rsTH.MoveNext
strGZ = ""
Sheet = ""
Next
End Sub

Function DH(str As String) As String
Select Case str
    Case "JS"
        DH = "给水"
    Case "YS"
        DH = "雨水"
    Case "WS"
        DH = "污水"
    Case "RQ"
        DH = "燃气"
    Case "GD", "LD"
        DH = "电力"
    Case "GY"
        DH = "工业"
    Case "DX"
        DH = "电信"
End Select
End Function

*********************************