excel坐标自动计算程序

gerogewilliam

excel坐标自动计算程序
由于超过2M，只能发代码



Sub zhuyedsasfasj122()
Dim strint21 As String
Sheets("AAA").Select
strint21 = Cells(1, 8)
If strint21 = "K" Then
Call YYYYYy
End If
If strint21 = "ZK" Then
  Call ZZZZZZZ
End If

End Sub



Sub YYYYYy()

Sheets("AAA").Select
Dim shuzhi As Double

shuzhi = 6
Rows("954:957").Clear
Do While Cells(shuzhi, 1) <> ""
''''''''''查单一数值'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      Dim conn As ADODB.Connection
      Dim rs As ADODB.Recordset
      Set conn = New ADODB.Connection
      Set rs = New ADODB.Recordset
      '配置连接串
      conn.ConnectionString = "Provider=SQLOLEDB;Server=laptop-qtnmhplf;Database=shiqiao20210920;Uid=asas;Pwd=123456"
      conn.Open
   Dim str99 As String
   str99 = "shiqiaoLedgerLedgerY1"                 ''''shiqiao石桥28天后桩基压实度1021
   Dim str98 As String
       str98 = Cells(shuzhi, 1)
       Sql = "select * from " & str99 & " where 里程 = '" & str98 & "'"
        Set rs = conn.Execute(Sql)                           '4、执行SQL命令，产生记录集
'设置表头
    Sheets("AAA").Select
    Dim i As Integer
    For i = 0 To rs.Fields.Count - 1
    Cells(954, i + 1) = rs.Fields(i).Name
Next
'将数据输出到工作表
    Range("A956").CopyFromRecordset rs
'关闭连接
    rs.Close: Set rs = Nothing
    conn.Close: Set conn = Nothing
''''''''''查单一数值'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''数值位置转移''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Cells(shuzhi, 40) = Cells(956, 5)
Cells(shuzhi, 41) = Cells(956, 6)
Cells(shuzhi, 42) = Cells(956, 2)
Cells(shuzhi, 43) = Cells(956, 10)
Cells(shuzhi, 44) = Cells(956, 11)
Cells(shuzhi, 45) = Cells(956, 12)
Cells(shuzhi, 46) = Cells(956, 13)
Cells(shuzhi, 47) = Cells(956, 14)
Cells(shuzhi, 48) = Cells(956, 15)
'''''''''''数值位置转移''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Int(Cells(shuzhi, 1) / 0.1) = Cells(shuzhi, 1) / 0.1 Then
'''MsgBox "'可以整除"

Else
''''MsgBox "'不可以整除"



'''''''''''''''''''''''查2个数值''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim num99 As Double
num99 = -5000
num999 = num99
Do While num999 < Cells(shuzhi, 1)
   
   
num999 = num999 + 0.1
Loop
''''''''''''''''''''''''查2个数值''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''2个数值查询-----------------------------------------------------------------------
Rows("954:957").Clear
'      Dim conn As ADODB.Connection
'      Dim rs As ADODB.Recordset
      Set conn = New ADODB.Connection
      Set rs = New ADODB.Recordset
      '配置连接串
      conn.ConnectionString = "Provider=SQLOLEDB;Server=laptop-qtnmhplf;Database=shiqiao20210920;Uid=asas;Pwd=123456"
      conn.Open
      
   ''' "Provider=sqloledb;Server=R9HDET7;Database=dbname;Uid=username;Pwd=password"    '''laptop-qtnmhplf     192.168.3.25
    ''  MsgBox ("连接成功！" & vbCrLf & "数据库状态：" & conn.State & vbCrLf & "数据库版本：" & conn.Version)
'    从test数据库的YGXM表中取出所有数据
'    rs.Open "select * from control point", conn
'''''''''SQL = "select distinct t1.编号,t1.姓名,t1.身份证号,t1.部门 " _
'''''''''    & "from 员工 t1 inner join 员工 t2 " _
'''''''''    & "on t1.姓名=t2.姓名 where t1.编号<>t2.编号 order by t1.姓名"

'   Dim str99 As String
   str99 = "shiqiaoLedgerLedgerY1"                 ''''shiqiao石桥28天后桩基压实度1021
     Dim str918 As Double
        Sheets("AAA").Select
        str918 = Left(num999, 7)
        str918 = Format(str918, "0.0")
        str981 = Left(num999 - 0.1, 7)
        str981 = Format(str981, "0.0")
        
        Sql1 = "select * from " & str99 & " where 里程 = '" & str918 & "'"
        Set rs1 = conn.Execute(Sql1)
   
   
        Sql = "select * from " & str99 & " where 里程 = '" & str981 & "'"
        Set rs = conn.Execute(Sql)                           '4、执行SQL命令，产生记录集
    '''Range("A451").CopyFromRecordset rs
'设置表头
    Sheets("AAA").Select
'    Dim i As Integer
    For i = 0 To rs.Fields.Count - 1
    Cells(954, i + 1) = rs.Fields(i).Name
Next
'将数据输出到工作表
    Range("A955").CopyFromRecordset rs
    Range("A956").CopyFromRecordset rs1
    '''Range("A955").CopyFromRecordset rs1
'关闭连接
'关闭连接
    rs.Close: Set rs = Nothing
    rs1.Close: Set rs1 = Nothing
    conn.Close: Set conn = Nothing
   

''''''''''''''''''''''''''''''2个数值查询------------------------------------------------------------
''''''''''''''''''''''''''''''''''''''''''
                t = 955
                num1 = Cells(shuzhi, 1) - Cells(t, 1)                 '''' 桩号差值
                num2 = Cells(t + 1, 1) - Cells(t, 1)     '''' 整桩号之间比值
                num3 = num1 / num2                    ''' 得到比值
                num4 = Cells(t + 1, 5) - Cells(t, 5)  '''''x
                num5 = Cells(t + 1, 6) - Cells(t, 6) '''''y
                num6 = Cells(t + 1, 2) - Cells(t, 2) '''''z
                num7 = Cells(t + 1, 11) - Cells(t, 11)  '''''
                num8 = Cells(t + 1, 10) - Cells(t, 10)  '''''
                ''''''''' '''''''''''''''''''''''
                  '''Set Sheets("AAA") = sheetall
                  Set sheetall = Sheets("AAA")
                                             sheetall.Cells(shuzhi, 40) = Cells(955, 5) + num3 * num4    ''''x
                                             sheetall.Cells(shuzhi, 41) = Cells(955, 6) + num3 * num5     ''''y
                                             sheetall.Cells(shuzhi, 42) = Cells(955, 2) + num3 * num6     ''''h
                                             sheetall.Cells(shuzhi, 43) = Cells(955, 10) + num3 * num8     '''' 角度
                                             sheetall.Cells(shuzhi, 44) = Cells(955, 11) + num3 * num7     '''' 转换角度
                                             sheetall.Cells(shuzhi, 45) = Cells(955, 12)    '''' 和路面转换角度
                                             sheetall.Cells(shuzhi, 46) = Cells(955, 13)      '''' 和路面角度
                                             sheetall.Cells(shuzhi, 47) = Cells(955, 14)  ''''横坡左
                                             sheetall.Cells(shuzhi, 48) = Cells(955, 15)  ''''横坡右
''''''''''''''''''''''''''''''''''''''''''
End If
shuzhi = shuzhi + 1
Loop
Call gzhuanghaojisuanuhhoo
End Sub

Sub gzhuanghaojisuanuhhoo()
'''''''''主页的桩号计算
Sheets("AAA").Select
Dim nummmop As Double
nummmop = 6
Do While Cells(nummmop, 40) <> ""
For oooo = 40 To 48 Step 1
Cells(nummmop, oooo) = CDbl(Cells(nummmop, oooo))
Next oooo
nummmop = nummmop + 1
Loop
Dim numb1 As Integer
numb1 = 6
Do While Cells(numb1, 1) <> ""
   If Cells(numb1, 2) <> "" Then '''''''左
       numb2 = Cells(numb1, 2)
       Cells(numb1, 4) = Cells(numb1, 40) + numb2 * Cos(Cells(numb1, 44) - Cells(numb1, 45))
       Cells(numb1, 5) = Cells(numb1, 41) + numb2 * Sin(Cells(numb1, 44) - Cells(numb1, 45))
       Cells(numb1, 6) = Cells(numb1, 42) - numb2 * (Cells(numb1, 47) / 100)
      
    Else
          numb3 = Cells(numb1, 3) '''''''右
          Cells(numb1, 4) = Cells(numb1, 40) + numb3 * Cos(Cells(numb1, 44) + Cells(numb1, 45))
          Cells(numb1, 5) = Cells(numb1, 41) + numb3 * Sin(Cells(numb1, 44) + Cells(numb1, 45))
          Cells(numb1, 6) = Cells(numb1, 42) - numb3 * (Cells(numb1, 48) / 100)
    End If
         
numb1 = numb1 + 1
Loop

End Sub