Update VBA modules and test formatting

- 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>

VBA/DocumentModules/Sheet5.cls

@@ -0,0 +1,12 @@
+Private Sub CommandButton1_Click()
+    Dim ws As Worksheet
+    Set ws = ThisWorkbook.Worksheets("货期检查")
+    ws.Range("A4:P10000").ClearContents
+    Call RunDeliveryCheck
+End Sub
+
+Private Sub CommandButton2_Click()
+    Call SyncModifiedDatesToAccess
+    Call ArchiveModifiedData
+    Call UpdateSourceDataCopy
+End Sub

VBA/Modules/Module_Archive.bas

@@ -0,0 +1,99 @@
+'=============================================================================
+' 模块：数据存档模块
+' 功能：将[货期检查]中“修正交货日期”不为空的数据，追加到存档工作簿中
+'=============================================================================
+Option Explicit
+
+'-----------------------------------------------------------------------------
+' 主过程：归档已修正货期的数据
+'-----------------------------------------------------------------------------
+Public Sub ArchiveModifiedData()
+    Dim wsSrc As Worksheet
+    Dim srcLastRow As Long
+
+    Dim tgtFilePath As String
+    Dim wbTgt As Workbook
+    Dim wsTgt As Worksheet
+    Dim tgtLastRow As Long
+
+    Dim srcData As Variant
+    Dim outData() As Variant
+    Dim r As Long, c As Long
+    Dim validCount As Long
+
+    Set wsSrc = ThisWorkbook.Worksheets("货期检查")
+    srcLastRow = wsSrc.Cells(wsSrc.Rows.count, 1).End(xlUp).Row
+
+    If srcLastRow < 4 Then
+        MsgBox "没有数据可以存档！", vbExclamation
+        Exit Sub
+    End If
+
+    tgtFilePath = ThisWorkbook.Path & "\常规产品生产周期_总表.xlsx"
+
+    If Dir(tgtFilePath) = "" Then
+        MsgBox "找不到存档文件，请确认该文件是否与当前表格在同一目录下：" & vbCrLf & tgtFilePath, vbCritical
+        Exit Sub
+    End If
+
+    ' ★ 将源数据第4行到最后一行的1至17列（增加了一列）读入内存数组
+    srcData = wsSrc.Range(wsSrc.Cells(4, 1), wsSrc.Cells(srcLastRow, 17)).Value
+
+    ' ★ 准备输出数组，共 18 列（17列基础数据 + 1列处理日期）
+    ReDim outData(1 To UBound(srcData, 1), 1 To 18)
+    validCount = 0
+
+    For r = 1 To UBound(srcData, 1)
+        ' ★ 第11列为“修正交货日期”
+        If Trim(CStr(srcData(r, 11))) <> "" Then
+            validCount = validCount + 1
+
+            ' 复制前17列数据
+            For c = 1 To 17
+                outData(validCount, c) = srcData(r, c)
+            Next c
+
+            ' 第18列写入今天的日期
+            outData(validCount, 18) = Date
+        End If
+    Next r
+
+    If validCount = 0 Then
+        MsgBox "未发现填有【修正交货日期】的数据，无需存档。", vbInformation
+        Exit Sub
+    End If
+
+    Application.ScreenUpdating = False
+    Application.DisplayAlerts = False
+
+    On Error GoTo ErrorHandler
+
+    Set wbTgt = Workbooks.Open(Filename:=tgtFilePath, UpdateLinks:=False)
+    Set wsTgt = wbTgt.Worksheets("总表")
+
+    tgtLastRow = wsTgt.Cells(wsTgt.Rows.count, 1).End(xlUp).Row
+
+    ' ★ 写入区域宽度改为 18 列
+    wsTgt.Range(wsTgt.Cells(tgtLastRow + 1, 1), wsTgt.Cells(tgtLastRow + validCount, 18)).Value = outData
+
+    wbTgt.Close SaveChanges:=True
+
+    Application.DisplayAlerts = True
+    Application.ScreenUpdating = True
+
+    MsgBox "存档成功！共将 " & validCount & " 条修改记录追加到了总表中。", vbInformation
+    Exit Sub
+
+ErrorHandler:
+    Dim errDesc As String
+    errDesc = Err.Description
+
+    Application.DisplayAlerts = True
+    Application.ScreenUpdating = True
+
+    On Error Resume Next
+    If Not wbTgt Is Nothing Then wbTgt.Close SaveChanges:=False
+    On Error GoTo 0
+
+    MsgBox "存档过程中发生错误：" & vbCrLf & errDesc, vbCritical
+End Sub

VBA/Modules/Module_Database.bas

@@ -0,0 +1,119 @@
+'-----------------------------------------------------------------------------
+' 主过程：同步修改记录到数据库
+'-----------------------------------------------------------------------------
+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

VBA/Modules/Module_Main.bas

@@ -0,0 +1,599 @@
+'=============================================================================
+' 模块：货期检查主模块
+' 功能：从[生产订单明细查询]提取数据到[货期检查]，并完成货期分析计算
+'=============================================================================
+Option Explicit
+
+'-----------------------------------------------------------------------------
+' 主入口函数
+' 功能：协调各子模块完成完整的货期检查流程
+'-----------------------------------------------------------------------------
+Public Sub RunDeliveryCheck()
+    Application.ScreenUpdating = False
+    Application.Calculation = xlCalculationManual
+
+    On Error GoTo ErrorHandler
+
+    ' 1. 提取生产订单数据到货期检查表
+    Call ExtractOrderData
+
+    ' 2. 调用分类器填充产品分类
+    Call FillProductClassification
+
+    ' 3. 计算货期相关字段
+    Call CalculateDeliveryFields
+
+    ' 4. 自动推算修正交货日期
+    Call AutoCalculateRevisedDate
+
+    Application.Calculation = xlCalculationAutomatic
+    Application.ScreenUpdating = True
+    MsgBox "货期检查完成！", vbInformation
+
+    Exit Sub
+
+ErrorHandler:
+    Application.Calculation = xlCalculationAutomatic
+    Application.ScreenUpdating = True
+    MsgBox "运行出错：" & Err.Description, vbCritical
+End Sub
+
+'-----------------------------------------------------------------------------
+' 子模块1：从同目录下的[生产订单明细查询.xlsx]提取数据到[货期检查]第4行起
+' 提取字段：销售合同号,排产号,序号,产品名称,技术参数,型号,业务员,数量,签订日期,交货日期
+' 注：第11列为“修正交货日期”，留空由用户填写
+'-----------------------------------------------------------------------------
+Private Sub ExtractOrderData()
+    Dim srcFilePath As String ' 源文件路径
+    Dim wbSrc As Workbook    ' 源工作簿
+    Dim wsSrc As Worksheet   ' 源工作表
+    Dim wsDst As Worksheet   ' 目标工作表
+    Dim srcData As Variant   ' 源数据数组
+    Dim dstData As Variant   ' 目标写入数组
+    Dim colMap(1 To 10) As Long  ' ★ 目标10个字段在源表中的列索引
+
+    ' ★ 目标字段名（前10列，增加销售合同号放在第1列）
+    Dim targetFields(1 To 10) As String
+    targetFields(1) = "销售合同号"
+    targetFields(2) = "排产号"
+    targetFields(3) = "序号"
+    targetFields(4) = "产品名称"
+    targetFields(5) = "技术参数"
+    targetFields(6) = "型号"
+    targetFields(7) = "业务员"
+    targetFields(8) = "数量"
+    targetFields(9) = "签订日期"
+    targetFields(10) = "交货日期"
+
+    srcFilePath = ThisWorkbook.Path & "\生产订单明细查询.xlsx"
+
+    If Dir(srcFilePath) = "" Then
+        MsgBox "找不到数据源文件，请检查该文件是否与当前表格在同一目录下：" & vbCrLf & srcFilePath, vbCritical
+        Exit Sub
+    End If
+
+    Set wsDst = ThisWorkbook.Worksheets("货期检查")
+    Set wbSrc = Workbooks.Open(Filename:=srcFilePath, ReadOnly:=True)
+
+    On Error Resume Next
+    Set wsSrc = wbSrc.Worksheets("生产订单明细查询")
+    On Error GoTo 0
+
+    If wsSrc Is Nothing Then
+        MsgBox "在源文件中找不到工作表 [生产订单明细查询]！", vbCritical
+        wbSrc.Close SaveChanges:=False
+        Exit Sub
+    End If
+
+    Dim srcLastRow As Long
+    Dim srcLastCol As Long
+    srcLastRow = wsSrc.Cells(wsSrc.Rows.count, 1).End(xlUp).Row
+    srcLastCol = wsSrc.Cells(1, wsSrc.Columns.count).End(xlToLeft).Column
+
+    If srcLastRow < 2 Then
+        MsgBox "[生产订单明细查询.xlsx] 中无数据行！", vbExclamation
+        wbSrc.Close SaveChanges:=False
+        Exit Sub
+    End If
+
+    srcData = wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(srcLastRow, srcLastCol)).Value
+    wbSrc.Close SaveChanges:=False
+
+    Dim i As Long, j As Long
+    For i = 1 To 10
+        colMap(i) = 0
+        For j = 1 To srcLastCol
+            If Trim(CStr(srcData(1, j))) = targetFields(i) Then
+                colMap(i) = j
+                Exit For
+            End If
+        Next j
+        If colMap(i) = 0 Then
+            MsgBox "源表中找不到字段：" & targetFields(i), vbCritical
+            Exit Sub
+        End If
+    Next i
+
+    Dim dstLastRow As Long
+    dstLastRow = wsDst.Cells(wsDst.Rows.count, 1).End(xlUp).Row
+    If dstLastRow >= 4 Then
+        wsDst.Rows("4:" & dstLastRow).ClearContents
+    End If
+
+    Dim dataRowCount As Long
+    dataRowCount = srcLastRow - 1
+
+    ' ★ 目标表总列数变为17列
+    ReDim dstData(1 To dataRowCount, 1 To 17)
+
+    Dim r As Long
+    For r = 1 To dataRowCount
+        Dim srcRow As Long
+        srcRow = r + 1
+
+        ' 写入前10个提取字段
+        For i = 1 To 10
+            dstData(r, i) = srcData(srcRow, colMap(i))
+        Next i
+    Next r
+
+    ' 写入数据并取消自动换行
+    wsDst.Range(wsDst.Cells(4, 1), wsDst.Cells(3 + dataRowCount, 17)).Value = dstData
+    With wsDst.Range(wsDst.Cells(4, 1), wsDst.Cells(3 + dataRowCount, 17))
+        .WrapText = False
+        .Rows.AutoFit
+    End With
+End Sub
+
+'-----------------------------------------------------------------------------
+' 子模块2：调用GaugeClassifier对[货期检查]的"型号"列进行分类
+' 结果写入"产品分类"列（现为第12列）
+'-----------------------------------------------------------------------------
+Private Sub FillProductClassification()
+    Dim ws As Worksheet
+    Set ws = ThisWorkbook.Worksheets("货期检查")
+
+    Dim lastRow As Long
+    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+
+    If lastRow < 4 Then Exit Sub
+
+    ' ★ 读取型号列（插入字段后现为第6列）
+    Dim modelArr As Variant
+    modelArr = ws.Range(ws.Cells(4, 6), ws.Cells(lastRow, 6)).Value
+
+    Dim rowCount As Long
+    rowCount = lastRow - 3
+
+    Dim classArr() As Variant
+    ReDim classArr(1 To rowCount, 1 To 1)
+
+    Dim classifier As New GaugeClassifier
+
+    Dim r As Long
+    For r = 1 To rowCount
+        classArr(r, 1) = classifier.Classify(CStr(modelArr(r, 1)))
+    Next r
+
+    ' ★ 写入产品分类列（现为第12列）
+    ws.Range(ws.Cells(4, 12), ws.Cells(lastRow, 12)).Value = classArr
+End Sub
+
+'-----------------------------------------------------------------------------
+' 子模块3：计算所有货期相关字段
+'   第13列 BIP货期（日历天）
+'   第14列 BIP货期（工作日）
+'   第15列 工厂货期（工作日）
+'   第16列 BIP货期是否合理
+'   第17列 差值
+'-----------------------------------------------------------------------------
+Private Sub CalculateDeliveryFields()
+    Dim ws As Worksheet
+    Set ws = ThisWorkbook.Worksheets("货期检查")
+
+    Dim lastRow As Long
+    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+    If lastRow < 4 Then Exit Sub
+
+    Dim rowCount As Long
+    rowCount = lastRow - 3
+
+    Dim signDateArr  As Variant  ' 签订日期 (第9列)
+    Dim delivDateArr As Variant  ' 交货日期 (第10列)
+    Dim classArr     As Variant  ' 产品分类 (第12列)
+    Dim qtyArr       As Variant  ' 数量 (第8列)
+
+    ' ★ 修正读取数据的列索引
+    signDateArr = ws.Range(ws.Cells(4, 9), ws.Cells(lastRow, 9)).Value
+    delivDateArr = ws.Range(ws.Cells(4, 10), ws.Cells(lastRow, 10)).Value
+    classArr = ws.Range(ws.Cells(4, 12), ws.Cells(lastRow, 12)).Value
+    qtyArr = ws.Range(ws.Cells(4, 8), ws.Cells(lastRow, 8)).Value
+
+    Dim holidays As Object
+    Set holidays = LoadHolidays()
+
+    Dim factoryLeadTable As Variant
+    Dim factoryCategories() As String
+    Dim factoryRanges() As String
+    Call LoadFactoryLeadTable(factoryLeadTable, factoryCategories, factoryRanges)
+
+    Dim outArr() As Variant
+    ReDim outArr(1 To rowCount, 1 To 5)
+
+    Dim r As Long
+    For r = 1 To rowCount
+        Dim signDate  As Date
+        Dim delivDate As Date
+        Dim category  As String
+        Dim qty       As Long
+        Dim bipCalendar As Long
+        Dim bipWorkday  As Long
+        Dim factoryWD   As Long
+
+        If IsEmpty(signDateArr(r, 1)) Or IsEmpty(delivDateArr(r, 1)) Then
+            GoTo NextRow
+        End If
+
+        signDate = CDate(signDateArr(r, 1))
+        delivDate = CDate(delivDateArr(r, 1))
+        category = CStr(classArr(r, 1))
+        qty = CLng(qtyArr(r, 1))
+
+        bipCalendar = DateDiff("d", signDate, delivDate)
+        bipWorkday = CalcWorkdays(signDate, delivDate, holidays)
+        factoryWD = LookupFactoryLead(category, qty, factoryLeadTable, factoryCategories, factoryRanges)
+
+        Dim isReasonable As String
+        If factoryWD <= bipWorkday Then
+            isReasonable = "合理"
+        Else
+            isReasonable = "不合理"
+        End If
+
+        Dim diff As Long
+        diff = bipWorkday - factoryWD
+
+        outArr(r, 1) = bipCalendar
+        outArr(r, 2) = bipWorkday
+        outArr(r, 3) = factoryWD
+        outArr(r, 4) = isReasonable
+        outArr(r, 5) = diff
+
+NextRow:
+    Next r
+
+    ' ★ 一次性写入第13-17列
+    ws.Range(ws.Cells(4, 13), ws.Cells(lastRow, 17)).Value = outArr
+End Sub
+
+'-----------------------------------------------------------------------------
+' 子模块4：自动推算修正交货日期（按排产号统一计算）
+'-----------------------------------------------------------------------------
+Private Sub AutoCalculateRevisedDate()
+    Dim ws As Worksheet
+    Set ws = ThisWorkbook.Worksheets("货期检查")
+
+    Dim lastRow As Long
+    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+    If lastRow < 4 Then Exit Sub
+
+    Dim rowCount As Long
+    rowCount = lastRow - 3
+
+    Const N As Long = -3
+
+    Dim holidays As Object
+    Set holidays = LoadHolidays()
+
+    ' ★ 读取所需列：排产号(2), 签订日期(9), 工厂货期_工作日(15), 差值(17)
+    Dim pcNoArr As Variant, signDateArr As Variant, factoryWdArr As Variant, diffArr As Variant
+    pcNoArr = ws.Range(ws.Cells(4, 2), ws.Cells(lastRow, 2)).Value
+    signDateArr = ws.Range(ws.Cells(4, 9), ws.Cells(lastRow, 9)).Value
+    factoryWdArr = ws.Range(ws.Cells(4, 15), ws.Cells(lastRow, 15)).Value
+    diffArr = ws.Range(ws.Cells(4, 17), ws.Cells(lastRow, 17)).Value
+
+    Dim dictNeedRevise As Object
+    Dim dictMaxDate As Object
+    Set dictNeedRevise = CreateObject("Scripting.Dictionary")
+    Set dictMaxDate = CreateObject("Scripting.Dictionary")
+
+    Dim r As Long
+    Dim pcNo As String
+
+    For r = 1 To rowCount
+        pcNo = Trim(CStr(pcNoArr(r, 1)))
+        If pcNo <> "" Then
+            If Not dictNeedRevise.Exists(pcNo) Then
+                dictNeedRevise.Add pcNo, False
+                dictMaxDate.Add pcNo, CDate(0)
+            End If
+
+            If IsNumeric(diffArr(r, 1)) And Not IsEmpty(diffArr(r, 1)) Then
+                If CLng(diffArr(r, 1)) <= N Then
+                    dictNeedRevise(pcNo) = True
+                End If
+            End If
+
+            If IsDate(signDateArr(r, 1)) And IsNumeric(factoryWdArr(r, 1)) Then
+                Dim signDate As Date
+                Dim factoryWD As Long
+                Dim reqDate As Date
+
+                signDate = CDate(signDateArr(r, 1))
+                factoryWD = CLng(factoryWdArr(r, 1))
+                reqDate = AddWorkdays(signDate, factoryWD, holidays)
+
+                If reqDate > dictMaxDate(pcNo) Then
+                    dictMaxDate(pcNo) = reqDate
+                End If
+            End If
+        End If
+    Next r
+
+    Dim outArr() As Variant
+    ReDim outArr(1 To rowCount, 1 To 1)
+
+    For r = 1 To rowCount
+        pcNo = Trim(CStr(pcNoArr(r, 1)))
+        If pcNo <> "" Then
+            If dictNeedRevise(pcNo) = True Then
+                If dictMaxDate(pcNo) > CDate(0) Then
+                    outArr(r, 1) = dictMaxDate(pcNo)
+                Else
+                    outArr(r, 1) = Empty
+                End If
+            Else
+                outArr(r, 1) = Empty
+            End If
+        Else
+            outArr(r, 1) = Empty
+        End If
+    Next r
+
+    ' ★ 一次性写入第11列（修正交货日期）
+    ws.Range(ws.Cells(4, 11), ws.Cells(lastRow, 11)).Value = outArr
+End Sub
+
+'-----------------------------------------------------------------------------
+' 日期推算函数：在起始日期基础上往后加上指定的工作日数（自动跳过节假日）
+'-----------------------------------------------------------------------------
+Private Function AddWorkdays(startDate As Date, workDaysToAdd As Long, holidays As Object) As Date
+    Dim currentDate As Date
+    Dim addedDays As Long
+
+    currentDate = startDate
+    addedDays = 0
+
+    ' 循环递增日期，直到累加的有效工作日达到工厂需要的天数
+    While addedDays < workDaysToAdd
+        currentDate = currentDate + 1
+        Dim dk As Long
+        dk = CLng(currentDate)
+
+        ' 如果字典(日历表)中找不到这一天，说明不是休息日，计为一个工作日
+        If Not holidays.Exists(dk) Then
+            addedDays = addedDays + 1
+        End If
+    Wend
+
+    AddWorkdays = currentDate
+End Function
+
+'=============================================================================
+' 辅助函数区
+'=============================================================================
+
+'-----------------------------------------------------------------------------
+' 从[日历]工作表加载节假日（是否休息=1/TRUE/"是"等）到Dictionary
+' 返回：key=日期序列号(Long)，value=True
+'-----------------------------------------------------------------------------
+Private Function LoadHolidays() As Object
+    Dim ws As Worksheet
+    ' ★ 修复：Worksheet 对象赋值必须使用 Set
+    Set ws = ThisWorkbook.Worksheets("日历")
+
+    Dim lastRow As Long
+    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+
+    Dim dict As Object
+    ' ★ 修复：CreateObject 返回对象，赋值必须使用 Set
+    Set dict = CreateObject("Scripting.Dictionary")
+
+    If lastRow < 2 Then
+        Set LoadHolidays = dict
+        Exit Function
+    End If
+
+    ' 读取全部数据（含表头）
+    Dim data As Variant
+    data = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 2)).Value
+
+    ' 找日期列和是否休息列
+    Dim dateCol As Long, restCol As Long
+    Dim c As Long
+    For c = 1 To 2
+        Select Case Trim(CStr(data(1, c)))
+            Case "日期":     dateCol = c
+            Case "是否休息": restCol = c
+        End Select
+    Next c
+
+    If dateCol = 0 Or restCol = 0 Then
+        MsgBox "[日历]工作表表头字段不符，请检查！", vbExclamation
+        Set LoadHolidays = dict
+        Exit Function
+    End If
+
+    Dim r As Long
+    For r = 2 To lastRow
+        If Not IsEmpty(data(r, dateCol)) Then
+            Dim restVal As Variant
+            restVal = data(r, restCol)
+            ' 支持多种"休息"标记：TRUE, 1, "是", "1", "TRUE"
+            Dim isRest As Boolean
+            isRest = (restVal = True) Or (restVal = 1) Or _
+                     (UCase(Trim(CStr(restVal))) = "是") Or _
+                     (Trim(CStr(restVal)) = "1") Or _
+                     (UCase(Trim(CStr(restVal))) = "TRUE")
+            If isRest Then
+                Dim dateKey As Long
+                dateKey = CLng(CDate(data(r, dateCol)))
+                If Not dict.Exists(dateKey) Then
+                    dict.Add dateKey, True
+                End If
+            End If
+        End If
+    Next r
+
+    Set LoadHolidays = dict
+End Function
+
+'-----------------------------------------------------------------------------
+' 计算两个日期之间的工作日数（不含节假日）
+' 说明：从startDate的次日到endDate，逐日判断是否为节假日
+'       工作日 = 日历天 - 节假日天数
+'-----------------------------------------------------------------------------
+Private Function CalcWorkdays(startDate As Date, endDate As Date, holidays As Object) As Long
+    Dim totalDays As Long
+    Dim holidayCount As Long
+    Dim d As Date
+
+    totalDays = DateDiff("d", startDate, endDate)
+
+    If totalDays <= 0 Then
+        CalcWorkdays = 0
+        Exit Function
+    End If
+
+    ' 遍历区间内每一天（不含startDate，含endDate）
+    holidayCount = 0
+    For d = startDate + 1 To endDate
+        Dim dk As Long
+        dk = CLng(d)
+        If holidays.Exists(dk) Then
+            holidayCount = holidayCount + 1
+        End If
+    Next d
+
+    CalcWorkdays = totalDays - holidayCount
+End Function
+
+'-----------------------------------------------------------------------------
+' 从[工厂货期]工作表加载货期查询表到二维数组
+' 输出：
+'   tableData      - 完整数据数组（不含表头行），行=产品分类，列=数量范围对应天数
+'   categories()   - 产品分类名称数组（与tableData行对应）
+'   rangeHeaders() - 数量范围表头字符串数组，如 "1-20","21-100","101-500"
+'-----------------------------------------------------------------------------
+Private Sub LoadFactoryLeadTable(ByRef tableData As Variant, _
+                                  ByRef categories() As String, _
+                                  ByRef rangeHeaders() As String)
+    Dim ws As Worksheet
+    ' ★ 修复：Worksheet 对象赋值必须使用 Set
+    Set ws = ThisWorkbook.Worksheets("工厂货期")
+
+    Dim lastRow As Long
+    Dim lastCol As Long
+    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+    lastCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
+
+    If lastRow < 2 Or lastCol < 2 Then Exit Sub
+
+    ' 读取全部数据含表头
+    Dim raw As Variant
+    raw = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value
+
+    ' 解析表头：第1列为产品分类，后续列为数量范围
+    Dim colCount As Long
+    colCount = lastCol - 1  ' 排除产品分类列
+    ReDim rangeHeaders(1 To colCount)
+    Dim c As Long
+    For c = 1 To colCount
+        rangeHeaders(c) = Trim(CStr(raw(1, c + 1)))
+    Next c
+
+    ' 解析数据行
+    Dim rowCount As Long
+    rowCount = lastRow - 1
+    ReDim categories(1 To rowCount)
+    ReDim tableData(1 To rowCount, 1 To colCount)
+
+    Dim r As Long
+    For r = 1 To rowCount
+        categories(r) = Trim(CStr(raw(r + 1, 1)))
+        For c = 1 To colCount
+            tableData(r, c) = raw(r + 1, c + 1)
+        Next c
+    Next r
+End Sub
+
+'-----------------------------------------------------------------------------
+' 根据产品分类和数量查询工厂货期（工作日）
+' 参数：
+'   category       - 产品分类名称
+'   qty            - 数量
+'   tableData      - 货期数值二维数组
+'   categories()   - 产品分类名称数组
+'   rangeHeaders() - 数量范围表头数组，如"1-20"
+' 返回：对应工厂货期天数，找不到返回0
+'-----------------------------------------------------------------------------
+Private Function LookupFactoryLead(category As String, qty As Long, _
+                                    tableData As Variant, _
+                                    categories() As String, _
+                                    rangeHeaders() As String) As Long
+    ' 找到对应的行（产品分类）
+    Dim targetRow As Long
+    targetRow = 0
+    Dim r As Long
+    For r = 1 To UBound(categories)
+        If categories(r) = category Then
+            targetRow = r
+            Exit For
+        End If
+    Next r
+
+    If targetRow = 0 Then
+        LookupFactoryLead = 0
+        Exit Function
+    End If
+
+    ' 找到对应的列（数量范围）
+    Dim targetCol As Long
+    targetCol = 0
+    Dim c As Long
+    For c = 1 To UBound(rangeHeaders)
+        Dim lo As Long, hi As Long
+        If ParseRange(rangeHeaders(c), lo, hi) Then
+            If qty >= lo And qty <= hi Then
+                targetCol = c
+                Exit For
+            End If
+        End If
+    Next c
+
+    If targetCol = 0 Then
+        ' 数量超出所有范围，取最后一列
+        targetCol = UBound(rangeHeaders)
+    End If
+
+    LookupFactoryLead = CLng(tableData(targetRow, targetCol))
+End Function
+
+'-----------------------------------------------------------------------------
+' 解析形如 "1-20", "21-100", "101-500" 的范围字符串
+' 输出：lo（下限），hi（上限）
+' 返回：True=解析成功，False=失败
+'-----------------------------------------------------------------------------
+Private Function ParseRange(rangeStr As String, ByRef lo As Long, ByRef hi As Long) As Boolean
+    Dim parts() As String
+    parts = Split(Trim(rangeStr), "-")
+    If UBound(parts) = 1 Then
+        On Error Resume Next
+        lo = CLng(Trim(parts(0)))
+        hi = CLng(Trim(parts(1)))
+        On Error GoTo 0
+        ParseRange = (lo > 0 And hi >= lo)
+    Else
+        ParseRange = False
+    End If
+End Function

VBA/Modules/Module_UpdateSource.bas

@@ -0,0 +1,156 @@
+'-----------------------------------------------------------------------------
+' 主过程：创建副本并更新数据
+'-----------------------------------------------------------------------------
+Public Sub UpdateSourceDataCopy()
+    Dim wsCheck As Worksheet
+    Dim lastRowCheck As Long, r As Long
+    Dim pcNo As String, seqNo As String, revDate As Variant
+
+    ' 使用字典存储需要修改的数据，键为 "排产号|序号"
+    Dim updateDict As Object
+    Set updateDict = CreateObject("Scripting.Dictionary")
+
+    ' ==========================================
+    ' 1. 读取 [货期检查] 中需要修改的数据
+    ' ==========================================
+    Set wsCheck = ThisWorkbook.Worksheets("货期检查")
+    lastRowCheck = wsCheck.Cells(wsCheck.Rows.count, 1).End(xlUp).Row
+
+    If lastRowCheck < 4 Then
+        MsgBox "没有数据！", vbExclamation
+        Exit Sub
+    End If
+
+    ' 遍历收集修正交货日期不为空的数据
+    For r = 4 To lastRowCheck
+        ' ★ 修正：第11列为修正交货日期
+        revDate = wsCheck.Cells(r, 11).Value
+
+        If Trim(CStr(revDate)) <> "" And IsDate(revDate) Then
+            ' ★ 修正：排产号现为第2列，序号现为第3列
+            pcNo = Trim(CStr(wsCheck.Cells(r, 2).Value))
+            seqNo = Trim(CStr(wsCheck.Cells(r, 3).Value))
+
+            If pcNo <> "" And seqNo <> "" Then
+                ' 组合排产号和序号作为唯一主键
+                updateDict(pcNo & "|" & seqNo) = Format(CDate(revDate), "yyyy-mm-dd")
+            End If
+        End If
+    Next r
+
+    ' 如果字典为空，说明没有需要修改的记录
+    If updateDict.count = 0 Then
+        MsgBox "未发现填有【修正交货日期】的有效数据，无需生成副本和修改。", vbInformation
+        Exit Sub
+    End If
+
+    ' ==========================================
+    ' 2. 复制原始文件，生成带时间戳的副本
+    ' ==========================================
+    Dim srcPath As String, copyPath As String
+    Dim timeStamp As String
+
+    srcPath = ThisWorkbook.Path & "\生产订单明细查询.xlsx"
+    If Dir(srcPath) = "" Then
+        MsgBox "找不到源文件：" & srcPath, vbCritical
+        Exit Sub
+    End If
+
+    ' 生成精确到秒的时间戳，例如: 20260302_143005
+    timeStamp = Format(Now, "yyyymmdd_hhmmss")
+    copyPath = ThisWorkbook.Path & "\生产订单明细查询_" & timeStamp & ".xlsx"
+
+    ' 复制文件
+    On Error Resume Next
+    FileCopy srcPath, copyPath
+    If Err.Number <> 0 Then
+        MsgBox "创建副本文件失败！请检查源文件是否正被其他程序打开占用。" & vbCrLf & Err.Description, vbCritical
+        On Error GoTo 0
+        Exit Sub
+    End If
+    On Error GoTo 0
+
+    ' ==========================================
+    ' 3. 打开副本文件并修改对应的交货日期
+    ' ==========================================
+    Dim wbCopy As Workbook
+    Dim wsCopy As Worksheet
+    Dim lastRowCopy As Long, lastColCopy As Long
+    Dim colPcNo As Long, colSeqNo As Long, colDate As Long
+    Dim i As Long
+    Dim headerVal As String
+    Dim modifiedCount As Long
+
+    Application.ScreenUpdating = False
+    Application.DisplayAlerts = False ' 屏蔽可能出现的保存提示
+
+    On Error GoTo ErrorHandler
+
+    ' 后台打开刚刚生成的副本文件
+    Set wbCopy = Workbooks.Open(Filename:=copyPath)
+    Set wsCopy = wbCopy.Worksheets("生产订单明细查询")
+
+    lastRowCopy = wsCopy.Cells(wsCopy.Rows.count, 1).End(xlUp).Row
+    lastColCopy = wsCopy.Cells(1, wsCopy.Columns.count).End(xlToLeft).Column
+
+    ' 动态查找副本文件中目标字段的列号 (防止数据源列顺序变动)
+    For i = 1 To lastColCopy
+        headerVal = Trim(CStr(wsCopy.Cells(1, i).Value))
+        Select Case headerVal
+            Case "排产号": colPcNo = i
+            Case "序号": colSeqNo = i
+            Case "交货日期": colDate = i
+        End Select
+    Next i
+
+    ' 校验必要字段是否都找到了
+    If colPcNo = 0 Or colSeqNo = 0 Or colDate = 0 Then
+        MsgBox "在副本文件中找不到【排产号】、【序号】或【交货日期】列，修改失败！", vbCritical
+        wbCopy.Close SaveChanges:=False
+        Application.ScreenUpdating = True
+        Application.DisplayAlerts = True
+        Exit Sub
+    End If
+
+    modifiedCount = 0
+
+    ' 遍历副本文件的数据行（第1行是表头，从第2行开始）
+    For r = 2 To lastRowCopy
+        pcNo = Trim(CStr(wsCopy.Cells(r, colPcNo).Value))
+        seqNo = Trim(CStr(wsCopy.Cells(r, colSeqNo).Value))
+
+        If pcNo <> "" And seqNo <> "" Then
+            ' 如果当前订单项存在于我们需要修改的字典中
+            If updateDict.Exists(pcNo & "|" & seqNo) Then
+                ' 将原来的交货日期替换为字典里存的修正交货日期
+                wsCopy.Cells(r, colDate).Value = updateDict(pcNo & "|" & seqNo)
+                modifiedCount = modifiedCount + 1
+            End If
+        End If
+    Next r
+
+    ' 保存并关闭副本文件
+    wbCopy.Close SaveChanges:=True
+
+    Application.DisplayAlerts = True
+    Application.ScreenUpdating = True
+
+    MsgBox "副本数据修改成功！" & vbCrLf & vbCrLf & _
+           "已生成新文件：生产订单明细查询_" & timeStamp & ".xlsx" & vbCrLf & _
+           "共精准替换了 " & modifiedCount & " 条订单的交货日期。", vbInformation
+
+    Exit Sub
+
+ErrorHandler:
+    Dim errDesc As String
+    errDesc = Err.Description
+
+    Application.DisplayAlerts = True
+    Application.ScreenUpdating = True
+
+    On Error Resume Next
+    If Not wbCopy Is Nothing Then wbCopy.Close SaveChanges:=False
+    On Error GoTo 0
+
+    MsgBox "修改副本文件时发生错误：" & vbCrLf & errDesc, vbCritical
+End Sub

VBA/Modules/TestModule.bas

@@ -47,10 +47,10 @@ Sub TestClassifierLogic()
 
         If passed Then
             passedCount = passedCount + 1
-            results = results & "[✓ PASS] Test " & (i + 1) & ": " & expected & vbCrLf
+            results = results & "[?? PASS] Test " & (i + 1) & ": " & expected & vbCrLf
         Else
             failedCount = failedCount + 1
-            results = results & "[✗ FAIL] Test " & (i + 1) & vbCrLf
+            results = results & "[?? FAIL] Test " & (i + 1) & vbCrLf
             results = results & "  Input:    " & Left(CStr(testCases(i)(0)), 50) & "..." & vbCrLf
             results = results & "  Expected: " & expected & vbCrLf
             results = results & "  Actual:   " & actual & vbCrLf & vbCrLf
@@ -160,7 +160,7 @@ Sub TestPerformance()
     ' Measure performance
     startTime = Timer
     For i = 1 To count
-        classifier.Classify(testStrings(i))
+        classifier.Classify (testStrings(i))
     Next i
     endTime = Timer
 

VBA/Modules/模块1.bas

@@ -0,0 +1,131 @@
+Option Explicit
+
+' 自定义工作日计算函数
+' 用法: =WORKDAYS_CUSTOM(开始日期, 结束日期)
+' 基于"2026年工作日历"表中的休息日数据计算工作日天数
+Function WORKDAYS_CUSTOM(startDate As Date, endDate As Date) As Long
+    Dim ws As Worksheet
+    Dim currentDate As Date
+    Dim workdayCount As Long
+    Dim lastRow As Long
+    Dim i As Long
+    Dim dateInSheet As Date
+    Dim isRest As String
+    Dim found As Boolean
+
+    On Error GoTo ErrorHandler
+
+    ' 确保开始日期小于等于结束日期
+    If startDate > endDate Then
+        WORKDAYS_CUSTOM = 0
+        Exit Function
+    End If
+
+    ' 获取工作表
+    Set ws = ThisWorkbook.Sheets("日历")
+
+    ' 找到最后一行
+    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
+
+    ' 初始化计数器
+    workdayCount = 0
+    currentDate = startDate
+
+    ' 遍历日期范围
+    Do While currentDate <= endDate
+        found = False
+
+        ' 在表中查找当前日期
+        For i = 2 To lastRow  ' 从第2行开始（第1行是表头）
+            dateInSheet = CDate(ws.Cells(i, 1).Value)
+
+            If dateInSheet = currentDate Then
+                isRest = ws.Cells(i, 2).Value
+                found = True
+
+                ' 如果不是休息日，计数加1
+                If isRest = "否" Then
+                    workdayCount = workdayCount + 1
+                End If
+
+                Exit For
+            End If
+        Next i
+
+        ' 如果日期不在表中（例如其他年份），返回错误
+        If Not found And Year(currentDate) = 2026 Then
+            WORKDAYS_CUSTOM = CVErr(xlErrValue)
+            Exit Function
+        End If
+
+        ' 移动到下一天
+        currentDate = DateAdd("d", 1, currentDate)
+    Loop
+
+    WORKDAYS_CUSTOM = workdayCount
+    Exit Function
+
+ErrorHandler:
+    WORKDAYS_CUSTOM = CVErr(xlErrValue)
+End Function
+
+
+' 优化版本：使用字典提高查询速度
+Function WORKDAYS_CUSTOM_FAST(startDate As Date, endDate As Date) As Long
+    Dim ws As Worksheet
+    Dim currentDate As Date
+    Dim workdayCount As Long
+    Dim lastRow As Long
+    Dim i As Long
+    Dim restDays As Object  ' Dictionary
+    Dim dateStr As String
+
+    On Error GoTo ErrorHandler
+
+    ' 确保开始日期小于等于结束日期
+    If startDate > endDate Then
+        WORKDAYS_CUSTOM_FAST = 0
+        Exit Function
+    End If
+
+    ' 创建字典对象
+    Set restDays = CreateObject("Scripting.Dictionary")
+
+    ' 获取工作表
+    Set ws = ThisWorkbook.Sheets("2026年工作日历")
+
+    ' 找到最后一行
+    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
+
+    ' 将所有休息日加载到字典中（提高查询速度）
+    For i = 2 To lastRow
+        If ws.Cells(i, 2).Value = "是" Then
+            dateStr = Format(CDate(ws.Cells(i, 1).Value), "yyyy-mm-dd")
+            restDays(dateStr) = True
+        End If
+    Next i
+
+    ' 初始化计数器
+    workdayCount = 0
+    currentDate = startDate
+
+    ' 遍历日期范围
+    Do While currentDate <= endDate
+        dateStr = Format(currentDate, "yyyy-mm-dd")
+
+        ' 检查是否为休息日
+        If Not restDays.Exists(dateStr) Then
+            ' 不在休息日字典中，说明是工作日
+            workdayCount = workdayCount + 1
+        End If
+
+        ' 移动到下一天
+        currentDate = DateAdd("d", 1, currentDate)
+    Loop
+
+    WORKDAYS_CUSTOM_FAST = workdayCount
+    Exit Function
+
+ErrorHandler:
+    WORKDAYS_CUSTOM_FAST = CVErr(xlErrValue)
+End Function

VBA/Modules/模块3.bas

@@ -0,0 +1,116 @@
+'=============================================================================
+' 临时排查脚本：精准定位“数据类型不匹配 (-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

VBA/Modules/模块4.bas

@@ -0,0 +1,106 @@
+'=============================================================================
+' 临时排查脚本：精准定位 OLE DB 多步操作错误 (-2147217887)
+'=============================================================================
+Sub DebugOleDbError()
+    Dim ws As Worksheet
+    Dim r 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
+    Dim fName As String
+    Dim valToVerify As Variant
+
+    dbPath = "\\192.168.110.114\生产进度表\2026年数据\执行卡下发记录.accdb"
+    connStr = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & dbPath & ";Uid=Admin;Pwd=;"
+
+    Set ws = ThisWorkbook.Worksheets("货期检查")
+
+    ' 找到第一条填写了【修正交货日期】的数据进行测试
+    For r = 4 To ws.Cells(ws.Rows.count, 1).End(xlUp).Row
+        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")
+    conn.Open connStr
+
+    pcNo = Replace(Trim(CStr(ws.Cells(testRow, 1).Value)), "'", "''")
+    seqNo = Trim(CStr(ws.Cells(testRow, 2).Value))
+
+    strSQL = "SELECT * FROM 货期修改记录 WHERE [排产号]='" & pcNo & "' AND [序号]=" & seqNo
+    Set rs = CreateObject("ADODB.Recordset")
+    rs.Open strSQL, conn, 1, 3
+
+    If rs.EOF Then rs.AddNew
+
+    ' ==========================================
+    ' 开始逐个字段缓慢写入，开启错误捕捉
+    ' ==========================================
+    On Error GoTo CatchErr
+
+    If rs.EOF Then
+        fName = "排产号": valToVerify = ws.Cells(testRow, 1).Value: rs.Fields(fName).Value = valToVerify
+        fName = "序号": valToVerify = ws.Cells(testRow, 2).Value: rs.Fields(fName).Value = valToVerify
+    End If
+
+    fName = "产品名称": valToVerify = ws.Cells(testRow, 3).Value: rs.Fields(fName).Value = valToVerify
+    fName = "规格": valToVerify = ws.Cells(testRow, 4).Value: rs.Fields(fName).Value = valToVerify
+    fName = "型号": valToVerify = ws.Cells(testRow, 5).Value: rs.Fields(fName).Value = valToVerify
+    fName = "业务员": valToVerify = ws.Cells(testRow, 6).Value: rs.Fields(fName).Value = valToVerify
+
+    fName = "数量"
+    If IsNumeric(ws.Cells(testRow, 7).Value) And Not IsEmpty(ws.Cells(testRow, 7).Value) Then
+        valToVerify = ws.Cells(testRow, 7).Value
+    Else
+        valToVerify = 0
+    End If
+    rs.Fields(fName).Value = valToVerify
+
+    fName = "签订日期": If IsDate(ws.Cells(testRow, 8).Value) Then valToVerify = CDate(ws.Cells(testRow, 8).Value): rs.Fields(fName).Value = valToVerify
+    fName = "交货日期": If IsDate(ws.Cells(testRow, 9).Value) Then valToVerify = CDate(ws.Cells(testRow, 9).Value): rs.Fields(fName).Value = valToVerify
+    fName = "修正交货日期": If IsDate(ws.Cells(testRow, 10).Value) Then valToVerify = CDate(ws.Cells(testRow, 10).Value): rs.Fields(fName).Value = valToVerify
+
+    fName = "产品分类": valToVerify = ws.Cells(testRow, 11).Value: rs.Fields(fName).Value = valToVerify
+    fName = "BIP货期": If IsNumeric(ws.Cells(testRow, 12).Value) Then valToVerify = ws.Cells(testRow, 12).Value: rs.Fields(fName).Value = valToVerify
+    fName = "BIP货期_工作日": If IsNumeric(ws.Cells(testRow, 13).Value) Then valToVerify = ws.Cells(testRow, 13).Value: rs.Fields(fName).Value = valToVerify
+    fName = "工厂货期_工作日": If IsNumeric(ws.Cells(testRow, 14).Value) Then valToVerify = ws.Cells(testRow, 14).Value: rs.Fields(fName).Value = valToVerify
+
+    fName = "添加记录的时间"
+    valToVerify = Now: rs.Fields(fName).Value = valToVerify
+
+    ' 最后一步提交
+    fName = "提交更新 (rs.Update)"
+    valToVerify = "无(最后提交环节)"
+    rs.Update
+
+    MsgBox "测试通过！说明第一条数据没问题。可能是后面的某一行数据触发了报错，我们可以进一步排查。"
+    rs.Close
+    conn.Close
+    Exit Sub
+
+CatchErr:
+    Dim errMsg As String
+    errMsg = Err.Description
+
+    ' 安全清理
+    On Error Resume Next
+    rs.CancelUpdate
+    rs.Close
+    conn.Close
+
+    MsgBox "?? 抓到导致 OLE DB 错误的内鬼了！" & vbCrLf & vbCrLf & _
+           "错误发生在处理字段：【" & fName & "】" & vbCrLf & _
+           "试图写入的值为：[" & CStr(valToVerify) & "]" & vbCrLf & vbCrLf & _
+           "?? 常见原因分析：" & vbCrLf & _
+           "1. 超长：这串内容是不是太长了？(超过了Access中该字段的长度限制)" & vbCrLf & _
+           "2. 空值拒绝：如果写入的值是空[]，检查Access中该字段是否设置了【必填=是】或【允许空字符串=否】。" & vbCrLf & _
+           "3. 如果错误发生在【提交更新】阶段，说明有必填字段被漏掉了！" & vbCrLf & vbCrLf & _
+           "系统报错: " & errMsg, vbCritical
+End Sub