admin/ProductionCycleCheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Update VBA modules and test formatting

Browse Source 
- 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>
This commit is contained in:
Misaka_Company
2026-04-24 10:20:00 +08:00
parent 88b85c47cf
commit c0f8d8163d
10 changed files with 1343 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
VBA/DocumentModules/Sheet5.cls Normal file
View File

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

99
VBA/Modules/Module_Archive.bas Normal file
View File

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

119
VBA/Modules/Module_Database.bas Normal file
View File

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

599
VBA/Modules/Module_Main.bas Normal file
View File

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

156
VBA/Modules/Module_UpdateSource.bas Normal file
View File

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

4
VBA/Modules/TestModule.bas
View File

@@ -47,10 +47,10 @@ Sub TestClassifierLogic()
If passed Then If passed Then
passedCount = passedCount + 1 passedCount = passedCount + 1
results = results & "[✓ PASS] Test " & (i + 1) & ": " & expected & vbCrLf results = results & "[?? PASS] Test " & (i + 1) & ": " & expected & vbCrLf
Else Else
failedCount = failedCount + 1 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 & " Input: " & Left(CStr(testCases(i)(0)), 50) & "..." & vbCrLf
results = results & " Expected: " & expected & vbCrLf results = results & " Expected: " & expected & vbCrLf
results = results & " Actual: " & actual & vbCrLf & vbCrLf results = results & " Actual: " & actual & vbCrLf & vbCrLf

131
VBA/Modules/模块1.bas Normal file
View File

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

116
VBA/Modules/模块3.bas Normal file
View File

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

106
VBA/Modules/模块4.bas Normal file
View File

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