'----------------------------------------------------------------------------- ' 主过程:创建副本并更新数据 '----------------------------------------------------------------------------- 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