*******************分界线******************
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