炼钢厂入库单

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单元格内容
  mystr = "execute  pu1rk_zhangzs  '" + Range("I6") + "'"
 ' mystr = "select top 1 * from mittra  "
 ' MsgBox (mystr)
  myrs.Open mystr '为 Recordset 赋值
 
  '如果没有查出记录
  If myrs.EOF Then
   MsgBox "质检站还没判定/您还没有入库操作!", vbOKOnly, "错误"
   Range("I6").Value = ""
   Exit Sub
  End If
 
 '为工作表解除保护
 'Worksheets("精整入库").Unprotect Password:="zhangzs"
 
 '插入所查询的数据
 Range("B6") = "库别:" + Trim(myrs!库位)
 Range("F6") = Trim(myrs!物料号)
 Range("C17") = Trim(myrs!交易日期)
 Range("B9") = Trim(myrs!炉号)
 Range("D9") = Trim(myrs!钢种)
 Range("F9") = Trim(myrs!铸坯外径)
 Range("H9") = Trim(myrs!定尺长度) + "m"
 
 If Trim(Trim(myrs!备注)) = "," Then
   Range("B15") = "备注： "
 Else
   Range("B15") = "备注： " + Trim(myrs!备注)
 End If
 
 n = 2 '初始变量
 m = 11
 Do While Not myrs.EOF
 Cells(11, n) = Trim(myrs!倍尺数)
 Cells(m + 1, n) = "支数"
 Cells(m + 1, n + 1) = "重量(t)"
 Cells(m + 2, n) = Trim(myrs!实际支数)
 Cells(m + 2, n + 1) = Trim(myrs!重量)
 myrs.MoveNext
 n = n + 2
 Loop
 'Worksheets("精整入库").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
 
  '总重量,总支数
  Range("J9") = Range("B13") + Range("D13") + Range("F13") + Range("H13") + Range("J13") + Range("L13")
  Range("L9") = Range("C13") + Range("E13") + Range("G13") + Range("I13") + Range("K13") + Range("M13")
  '关闭连接
  myrs.Close
  myCn.Close
  Exit Sub
 
 '出现错误执行以下代码
Error:
  MsgBox Err.Description, vbOKOnly, "Error Message"
End Sub
Sub pu1rk_clear()
 '取消工作表保护
 Worksheets("精整入库").Unprotect Password:="zhangzs"
 '清除部分单元格内容
 Range("B6") = "库别:"
 Range("F6") = ""
 Range("C17") = ""
 Range("B9") = ""
 Range("D9") = ""
 Range("F9") = ""
 Range("H9") = ""
 Range("C16") = ""
 Range("B11") = ""
 Range("D11") = ""
 Range("F11") = ""
 Range("H11") = ""
 Range("J11") = ""
 Range("L11") = ""
 Range("B15") = "备注："
 
 '清空总支数,总重量
  Range("J9") = ""
  Range("L9") = ""
 For i = 2 To 13
    For j = 12 To 13
     Cells(j, i) = ""
    Next j
 Next i
 '为工作表加保护
 'Worksheets("精整入库").Protect Password:="zhangzs", DrawingObjects:=True, contents:=True, Scenarios:=True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = 9 And Target.Row = 6 Then
   Call pu1rk_clear
   If Range("I6") <> "" Then
     Call Pu1rk_write
   End If
 End If
End Sub

--图片：