c0f8d8163d
- Fix test result indicators encoding (use ?? instead of Unicode symbols) - Add missing newlines at end of files - Add new VBA module files for main functionality Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
119 lines
4.5 KiB
QBasic
119 lines
4.5 KiB
QBasic
'-----------------------------------------------------------------------------
|
|
' 主过程：同步修改记录到数据库
|
|
'-----------------------------------------------------------------------------
|
|
Public Sub SyncModifiedDatesToAccess()
|
|
Dim ws As Worksheet
|
|
Dim lastRow As Long, r As Long
|
|
Dim modifiedCount As Long
|
|
|
|
Dim conn As Object, rs As Object
|
|
Dim connStr As String, strSQL As String
|
|
|
|
Dim dbPath As String
|
|
Dim tableName As String
|
|
dbPath = "\\192.168.110.114\生产进度表\2026年数据\执行卡下发记录.accdb"
|
|
tableName = "货期修改记录"
|
|
|
|
Set ws = ThisWorkbook.Worksheets("货期检查")
|
|
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
|
If lastRow < 4 Then Exit Sub
|
|
|
|
On Error GoTo ErrorHandler
|
|
Set conn = CreateObject("ADODB.Connection")
|
|
|
|
connStr = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & dbPath & ";Uid=Admin;Pwd=;"
|
|
conn.Open connStr
|
|
|
|
Set rs = CreateObject("ADODB.Recordset")
|
|
modifiedCount = 0
|
|
|
|
Application.ScreenUpdating = False
|
|
|
|
For r = 4 To lastRow
|
|
' ★ 第11列为“修正交货日期”
|
|
If Trim(CStr(ws.Cells(r, 11).Value)) <> "" Then
|
|
Dim pcNo As String, seqNo As String
|
|
|
|
' ★ 排产号(现为第2列)，序号(现为第3列)
|
|
pcNo = Replace(Trim(CStr(ws.Cells(r, 2).Value)), "'", "''")
|
|
seqNo = Trim(CStr(ws.Cells(r, 3).Value))
|
|
|
|
If pcNo <> "" And seqNo <> "" And IsNumeric(seqNo) Then
|
|
strSQL = "SELECT * FROM " & tableName & " WHERE [排产号]='" & pcNo & "' AND [序号]=" & seqNo
|
|
|
|
rs.Open strSQL, conn, 1, 3
|
|
|
|
If rs.EOF Then
|
|
rs.AddNew
|
|
rs.Fields("排产号").Value = ws.Cells(r, 2).Value
|
|
rs.Fields("序号").Value = ws.Cells(r, 3).Value
|
|
End If
|
|
|
|
' ★ 增加写入销售合同号（需确保数据库中有该字段，若无请注释此行）
|
|
rs.Fields("销售合同号").Value = ws.Cells(r, 1).Value
|
|
|
|
' ★ 以下全部偏移1列
|
|
rs.Fields("产品名称").Value = ws.Cells(r, 4).Value
|
|
rs.Fields("技术参数").Value = ws.Cells(r, 5).Value
|
|
rs.Fields("型号").Value = ws.Cells(r, 6).Value
|
|
rs.Fields("业务员").Value = ws.Cells(r, 7).Value
|
|
|
|
If IsNumeric(ws.Cells(r, 8).Value) And Not IsEmpty(ws.Cells(r, 8).Value) Then
|
|
rs.Fields("数量").Value = ws.Cells(r, 8).Value
|
|
Else
|
|
rs.Fields("数量").Value = 0
|
|
End If
|
|
|
|
If IsDate(ws.Cells(r, 9).Value) Then rs.Fields("签订日期").Value = CDate(ws.Cells(r, 9).Value)
|
|
If IsDate(ws.Cells(r, 10).Value) Then rs.Fields("交货日期").Value = CDate(ws.Cells(r, 10).Value)
|
|
If IsDate(ws.Cells(r, 11).Value) Then rs.Fields("修正交货日期").Value = CDate(ws.Cells(r, 11).Value)
|
|
|
|
rs.Fields("产品分类").Value = ws.Cells(r, 12).Value
|
|
|
|
If IsNumeric(ws.Cells(r, 13).Value) Then rs.Fields("BIP货期").Value = ws.Cells(r, 13).Value
|
|
If IsNumeric(ws.Cells(r, 14).Value) Then rs.Fields("BIP货期_工作日").Value = ws.Cells(r, 14).Value
|
|
If IsNumeric(ws.Cells(r, 15).Value) Then rs.Fields("工厂货期_工作日").Value = ws.Cells(r, 15).Value
|
|
|
|
rs.Fields("添加记录的时间").Value = Now
|
|
|
|
rs.Update
|
|
rs.Close
|
|
|
|
modifiedCount = modifiedCount + 1
|
|
End If
|
|
End If
|
|
Next r
|
|
|
|
conn.Close
|
|
Set rs = Nothing
|
|
Set conn = Nothing
|
|
Application.ScreenUpdating = True
|
|
|
|
If modifiedCount > 0 Then
|
|
MsgBox "同步成功！共更新/新增了 " & modifiedCount & " 条货期修改记录。", vbInformation
|
|
Else
|
|
MsgBox "没有发现填写了【修正交货日期】的有效记录，未执行任何同步。", vbInformation
|
|
End If
|
|
Exit Sub
|
|
|
|
ErrorHandler:
|
|
Dim errNum As Long, errDesc As String
|
|
errNum = Err.Number: errDesc = Err.Description
|
|
Application.ScreenUpdating = True
|
|
|
|
On Error Resume Next
|
|
If Not rs Is Nothing Then
|
|
If rs.State = 1 Then
|
|
If rs.EditMode <> 0 Then rs.CancelUpdate
|
|
rs.Close
|
|
End If
|
|
End If
|
|
If Not conn Is Nothing Then
|
|
If conn.State = 1 Then conn.Close
|
|
End If
|
|
On Error GoTo 0
|
|
|
|
MsgBox "同步到数据库时发生错误！" & vbCrLf & _
|
|
"错误编号: " & errNum & vbCrLf & _
|
|
"错误描述: " & errDesc, vbCritical
|
|
End Sub |