From c0f8d8163d6b6a852b84386ae172112ed6e50d4d Mon Sep 17 00:00:00 2001 From: Misaka_Company Date: Fri, 24 Apr 2026 10:20:00 +0800 Subject: [PATCH] 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) --- VBA/ClassModules/GaugeClassifier.cls | 2 +- VBA/DocumentModules/Sheet5.cls | 12 + VBA/Modules/Module_Archive.bas | 99 +++++ VBA/Modules/Module_Database.bas | 119 ++++++ VBA/Modules/Module_Main.bas | 599 +++++++++++++++++++++++++++ VBA/Modules/Module_UpdateSource.bas | 156 +++++++ VBA/Modules/TestModule.bas | 8 +- VBA/Modules/模块1.bas | 131 ++++++ VBA/Modules/模块3.bas | 116 ++++++ VBA/Modules/模块4.bas | 106 +++++ 10 files changed, 1343 insertions(+), 5 deletions(-) create mode 100644 VBA/DocumentModules/Sheet5.cls create mode 100644 VBA/Modules/Module_Archive.bas create mode 100644 VBA/Modules/Module_Database.bas create mode 100644 VBA/Modules/Module_Main.bas create mode 100644 VBA/Modules/Module_UpdateSource.bas create mode 100644 VBA/Modules/模块1.bas create mode 100644 VBA/Modules/模块3.bas create mode 100644 VBA/Modules/模块4.bas diff --git a/VBA/ClassModules/GaugeClassifier.cls b/VBA/ClassModules/GaugeClassifier.cls index b0eafeb..76c3f1a 100644 --- a/VBA/ClassModules/GaugeClassifier.cls +++ b/VBA/ClassModules/GaugeClassifier.cls @@ -165,4 +165,4 @@ Public Function GetMainModel(headString As String) As String End If GetMainModel = model -End Function +End Function \ No newline at end of file diff --git a/VBA/DocumentModules/Sheet5.cls b/VBA/DocumentModules/Sheet5.cls new file mode 100644 index 0000000..348211c --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/Module_Archive.bas b/VBA/Modules/Module_Archive.bas new file mode 100644 index 0000000..a83fc53 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/Module_Database.bas b/VBA/Modules/Module_Database.bas new file mode 100644 index 0000000..37820ed --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/Module_Main.bas b/VBA/Modules/Module_Main.bas new file mode 100644 index 0000000..2e52644 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/Module_UpdateSource.bas b/VBA/Modules/Module_UpdateSource.bas new file mode 100644 index 0000000..f1f026c --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/TestModule.bas b/VBA/Modules/TestModule.bas index 92686eb..eb61d75 100644 --- a/VBA/Modules/TestModule.bas +++ b/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 @@ -198,4 +198,4 @@ Sub TestSingleInput() MsgBox "型号: " & inputStr & vbCrLf & _ "分类: " & result, vbInformation, "测试结果" End If -End Sub +End Sub \ No newline at end of file diff --git a/VBA/Modules/模块1.bas b/VBA/Modules/模块1.bas new file mode 100644 index 0000000..0252add --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/模块3.bas b/VBA/Modules/模块3.bas new file mode 100644 index 0000000..c620059 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/VBA/Modules/模块4.bas b/VBA/Modules/模块4.bas new file mode 100644 index 0000000..396a7cf --- /dev/null +++ b/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 \ No newline at end of file