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>
116 lines
4.9 KiB
QBasic
116 lines
4.9 KiB
QBasic
'=============================================================================
|
||
' 临时排查脚本：精准定位“数据类型不匹配 (-2147217913)” 发生的具体位置
|
||
'=============================================================================
|
||
Sub DebugTypeMismatch()
|
||
Dim ws As Worksheet
|
||
Dim r As Long, lastRow As Long, testRow As Long
|
||
Dim conn As Object, rs As Object
|
||
Dim dbPath As String, connStr As String, strSQL As String
|
||
Dim pcNo As String, seqNo As String
|
||
|
||
dbPath = "\\192.168.110.114\生产进度表\2026年数据\执行卡下发记录.accdb"
|
||
connStr = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & dbPath & ";Uid=Admin;Pwd=;"
|
||
|
||
Set ws = ThisWorkbook.Worksheets("货期检查")
|
||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||
|
||
' 1. 找到第一行有【修正交货日期】的数据进行测试
|
||
testRow = 0
|
||
For r = 4 To lastRow
|
||
If Trim(CStr(ws.Cells(r, 10).Value)) <> "" Then
|
||
testRow = r
|
||
Exit For
|
||
End If
|
||
Next r
|
||
|
||
If testRow = 0 Then
|
||
MsgBox "没有找到填写了【修正交货日期】的数据，无法进行测试！", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Set conn = CreateObject("ADODB.Connection")
|
||
On Error Resume Next
|
||
conn.Open connStr
|
||
If Err.Number <> 0 Then
|
||
MsgBox "连接数据库失败，错误: " & Err.Description, vbCritical
|
||
Exit Sub
|
||
End If
|
||
On Error GoTo 0
|
||
|
||
pcNo = Replace(Trim(CStr(ws.Cells(testRow, 1).Value)), "'", "''")
|
||
seqNo = Replace(Trim(CStr(ws.Cells(testRow, 2).Value)), "'", "''")
|
||
|
||
' ==========================================
|
||
' 第一关：测试 SQL 查询语句
|
||
' ==========================================
|
||
strSQL = "SELECT * FROM 货期修改记录 WHERE [排产号]='" & pcNo & "' AND [序号]='" & seqNo & "'"
|
||
Set rs = CreateObject("ADODB.Recordset")
|
||
|
||
On Error Resume Next
|
||
rs.Open strSQL, conn, 1, 3
|
||
If Err.Number <> 0 Then
|
||
Dim sqlErr As String
|
||
sqlErr = Err.Description
|
||
On Error GoTo 0
|
||
MsgBox "?? 抓到内鬼了！（在查询阶段报错）" & vbCrLf & vbCrLf & _
|
||
"在执行判断是否存在旧记录的 SQL 语句时发生了类型不匹配！" & vbCrLf & _
|
||
"?? 原因极大概率是：Access 数据库中的【序号】（或排产号）被设置为了“数字”类型，" & vbCrLf & _
|
||
"而代码里加上了单引号把它们当“文本”去查了。" & vbCrLf & vbCrLf & _
|
||
"系统原始报错：" & sqlErr, vbCritical
|
||
|
||
If conn.State = 1 Then conn.Close
|
||
Exit Sub
|
||
End If
|
||
On Error GoTo 0
|
||
|
||
' ==========================================
|
||
' 第二关：测试各字段逐个赋值
|
||
' ==========================================
|
||
If rs.EOF Then rs.AddNew
|
||
|
||
Dim fieldsToTest As Variant
|
||
Dim colsToTest As Variant
|
||
Dim i As Integer
|
||
Dim fName As String, fVal As Variant
|
||
|
||
' 准备要测试的字段名和对应的 Excel 列号
|
||
fieldsToTest = Array("排产号", "序号", "产品名称", "技术参数", "型号", "业务员", "数量", "签订日期", "交货日期", "修正交货日期", "产品分类", "BIP货期", "BIP货期_工作日", "工厂货期_工作日")
|
||
colsToTest = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
|
||
|
||
For i = LBound(fieldsToTest) To UBound(fieldsToTest)
|
||
fName = fieldsToTest(i)
|
||
fVal = ws.Cells(testRow, colsToTest(i)).Value
|
||
|
||
On Error Resume Next
|
||
' 尝试赋值
|
||
rs.Fields(fName).Value = fVal
|
||
|
||
If Err.Number <> 0 Then
|
||
Dim fieldErr As String
|
||
fieldErr = Err.Description
|
||
On Error GoTo 0
|
||
|
||
MsgBox "?? 抓到内鬼了！（在写入阶段报错）" & vbCrLf & vbCrLf & _
|
||
"是在给字段【" & fName & "】写入数据时触发的类型不匹配！" & vbCrLf & _
|
||
"?? 准备写入的 Excel 值为：[" & CStr(fVal) & "]" & vbCrLf & _
|
||
"?? 该值在 VBA 中的数据类型识别为：" & TypeName(fVal) & vbCrLf & vbCrLf & _
|
||
"?? 原因分析：很可能是 Excel 里是个空单元格，或者是段文本，但 Access 里这个字段要求必须是数字/日期。" & vbCrLf & vbCrLf & _
|
||
"系统原始报错：" & fieldErr, vbCritical
|
||
|
||
rs.CancelUpdate
|
||
rs.Close
|
||
conn.Close
|
||
Exit Sub
|
||
End If
|
||
On Error GoTo 0
|
||
Next i
|
||
|
||
' 如果跑到了这里，说明完全没报错
|
||
rs.CancelUpdate ' 仅仅是测试，取消更新，防止产生脏数据
|
||
rs.Close
|
||
conn.Close
|
||
|
||
MsgBox "?? 排查完成！" & vbCrLf & vbCrLf & _
|
||
"奇怪的是，脚本测试了第一条数据，并没有发生报错。" & vbCrLf & _
|
||
"如果是这样，那可能意味着并不是每次都会报错，而是 Excel 里某一行特定的数据（比如某个数字没填留空了）导致了错误。我们需要重点检查那些空白单元格。", vbInformation
|
||
End Sub |