'写 判定部分数据
Sub Pu1zj_write()
Dim myCn As New ADODB.Connection
Dim myrs As New ADODB.Recordset
Dim strcon As String
'ADO数据库连接串
strcon = "PROVIDER=SQLOLEDB;SERVER=172.16.2.9;UID=sa;PWD=tpcims;DATABASE=JTQfmis_data" 'DL580-1
On Error GoTo Error:
myCn.ConnectionString = strcon
'设置超时时间，为0时表示，将一直等待到命令执行完毕
myCn.CommandTimeout = 0
myCn.Open
myrs.ActiveConnection = myCn
mystr_zj = "select * from 铸坯判定书_1 where 炉号= '" + CStr(Range("B3")) + "'"
myrs.Open mystr_zj
If myrs.EOF Then
MsgBox "质检站还没有判定!", vbOKOnly, "错误"
Exit Sub
End If
Range("E3") = Trim(myrs!订单)
Range("H3") = Trim(myrs!钢种)
Range("L3") = Trim(myrs!规格) + "mm"
Range("O3") = Trim(myrs!合同号)
Range("T5") = Trim(myrs!支数)
Range("T6") = Trim(myrs!重量)
Range("C2") = Trim(myrs!生产日期)
Range("R2") = Trim(myrs!判定日期)
'关闭连接
myrs.Close
myCn.Close
Exit Sub
'出现错误执行以下代码
Error:
MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
'在判定部分书写 定尺长度
Sub dc()
Dim myCn As New ADODB.Connection
Dim myrs As New ADODB.Recordset
Dim strcon As String
'ADO数据库连接串
strcon = "PROVIDER=SQLOLEDB;SERVER=172.16.2.2;UID=sa;PWD=tpcims;DATABASE=Movex12" 'DL580-1
On Error GoTo Error:
myCn.ConnectionString = strcon
'设置超时时间，为0时表示，将一直等待到命令执行完毕
myCn.CommandTimeout = 0
myCn.Open
myrs.ActiveConnection = myCn
mystr_zj = "select * from JTQPu1Pd2 where mo= '" + CStr(Range("E3")) + "'"
myrs.Open mystr_zj
Range("T4") = Trim(myrs!dc)
'关闭连接
myrs.Close
myCn.Close
Exit Sub
'出现错误执行以下代码
Error:
MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
'写 入库部分数据
Sub Pu1rk_write()
Dim myCn As New ADODB.Connection
Dim myrs As New ADODB.Recordset
Dim strcon As String
'ADO数据库连接串
strcon = "PROVIDER=SQLOLEDB;SERVER=172.16.2.2;UID=sa;PWD=tpcims;DATABASE=Movex12" 'DL580-1
On Error GoTo Error:
myCn.ConnectionString = strcon
'设置超时时间，为0时表示，将一直等待到命令执行完毕
myCn.CommandTimeout = 0
myCn.Open
myrs.ActiveConnection = myCn
'打开存储过程,参数为I3单元格内容
Range("E10") = Range("E3")
Range("O10") = Range("O3")
Range("C9") = Range("C2")
mystr = "execute pu1rk_zhangzs '" + CStr(Range("E10")) + "'"
' mystr = "select top 1 * from mittra "
' MsgBox (mystr)
myrs.Open mystr '为 Recordset 赋值
'如果没有查出记录
If myrs.EOF Then
MsgBox "精整还没有入库!", vbOKOnly, "错误"
Exit Sub
End If
'为工作表解除保护
' Worksheets("精整入库").Unprotect Password:="zhangzs"
'插入所查询的数据
Range("R9") = Trim(myrs!交易日期)
Range("B10") = Trim(myrs!炉号)
Range("H10") = Trim(myrs!钢种)
Range("L10") = Trim(myrs!铸坯外径)
Range("T10") = Trim(myrs!定尺长度) + "m"
'Range("C13") = Trim(myrs!操作者)
n = 2 '初始变量
m = 11
Do While Not myrs.EOF
Cells(m, n + 1) = Trim(myrs!倍尺数)
Cells(m + 1, n + 1) = Trim(myrs!实际支数)
Cells(m + 2, n + 1) = Trim(myrs!重量)
myrs.MoveNext
n = n + 3
Loop
' Worksheets("精整入库").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
'关闭连接
myrs.Close
myCn.Close
Exit Sub
'出现错误执行以下代码
Error:
MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
'对比结果显示
Sub Zj_Rk_Db()
' If Trim(Range("T4").Text) = Replace(Replace(Trim(Range("T10").Text), "m", ""), ".", "") + "0" Then
' Range("E16") = "OK"
' Range("E16").Font.ColorIndex = 10
' Range("E16").Font.Bold = True
' Else
' Range("E16") = "Error"
' Range("E16").Font.ColorIndex = 3
' Range("E16").Font.Bold = True
' End If
If Trim(Range("T5").Text) = Trim(Range("T11").Text) Then
Range("E17") = "OK"
Range("E17").Font.ColorIndex = 10
Range("E17").Font.Bold = True
Else
Range("E17") = "Error"
Range("E17").Font.ColorIndex = 3
Range("E17").Font.Bold = True
End If
If Trim(Range("T6").Text) = Trim(Range("T12").Text) Then
Range("E18") = "OK"
Range("E18").Font.ColorIndex = 10
Range("E18").Font.Bold = True
Else
Range("E18") = "Error"
Range("E18").Font.ColorIndex = 3
Range("E18").Font.Bold = True
End If
'批次跟踪
If Trim(Range("B3").Text) = Trim(Range("B10").Text) Then
Range("E19") = "OK"
Range("E19").Font.ColorIndex = 10
Range("E19").Font.Bold = True
Else
Range("E19") = "Error"
Range("E19").Font.ColorIndex = 3
Range("E19").Font.Bold = True
End If
End Sub
'清空记录
Sub Clear()
'判定部分清除
Range("C2") = ""
Range("R2") = ""
Range("E3") = ""
Range("H3") = ""
Range("L3") = ""
Range("O3") = ""
Range("T4") = ""
Range("T5") = ""
Range("T6") = ""
'入库部分清除
Range("C9") = ""
Range("R9") = ""
Range("B10") = ""
Range("H10") = ""
Range("O10") = ""
Range("L10") = ""
Range("E10") = ""
Range("T10") = ""
For i = 11 To 13
For j = 3 To 15
Cells(i, j) = ""
Next j
Next i
'清除对比结果
Range("E16") = ""
Range("E17") = ""
Range("E18") = ""
Range("E19") = ""
'清除库存交易历史内容
For i = 7 To 24
For j = 2 To 12
Worksheets("库存交易历史").Cells(i, j) = ""
Next j
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Row = 3 Then
Call Clear
If Range("B3") <> "" Then
Call Pu1zj_write
'Call dc
Call Pu1rk_write
Call Zj_Rk_Db
Call Pu1_kucun_write
End If
End If
End Sub
Sub Pu1_kucun_write()
Dim myCn As New ADODB.Connection
Dim myrs As New ADODB.Recordset
Dim strcon As String
'ADO数据库连接串
strcon = "PROVIDER=SQLOLEDB;SERVER=172.16.2.2;UID=sa;PWD=tpcims;DATABASE=man" 'DL580-1
On Error GoTo Error:
myCn.ConnectionString = strcon
'设置超时时间，为0时表示，将一直等待到命令执行完毕
myCn.CommandTimeout = 0
myCn.Open
myrs.ActiveConnection = myCn
mystr_zj = "execute pu1_kucun '" + CStr(Range("E10")) + "'"
myrs.Open mystr_zj
n = 2 '初始变量
m = 7
Do While Not myrs.EOF
Worksheets("库存交易历史").Cells(m, n) = Trim(myrs!操作者)
Worksheets("库存交易历史").Cells(m, n + 1) = Trim(myrs!物料号)
Worksheets("库存交易历史").Cells(m, n + 2) = Trim(myrs!订单号)
Worksheets("库存交易历史").Cells(m, n + 3) = Trim(myrs!炉号)
Worksheets("库存交易历史").Cells(m, n + 4) = Trim(myrs!倍尺数)
Worksheets("库存交易历史").Cells(m, n + 5) = Trim(myrs!入库重量)
Worksheets("库存交易历史").Cells(m, n + 6) = Trim(myrs!入库支数)
Worksheets("库存交易历史").Cells(m, n + 7) = Trim(myrs!实际支数)
Worksheets("库存交易历史").Cells(m, n + 8) = Trim(myrs!批号)
Worksheets("库存交易历史").Cells(m, n + 9) = Trim(myrs!库位)
Worksheets("库存交易历史").Cells(m, n + 10) = Trim(myrs!交易日期)
myrs.MoveNext
m = m + 1
Loop
'关闭连接
myrs.Close
myCn.Close
Exit Sub
'出现错误执行以下代码
Error:
MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
--图片：输入“炉号”后回车即可得到结果。
|
本类阅读TOP10