c0f8d8163d
- Fix test result indicators encoding (use ?? instead of Unicode symbols) - Add missing newlines at end of files - Add new VBA module files for main functionality Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
99 lines
3.2 KiB
QBasic
99 lines
3.2 KiB
QBasic
'=============================================================================
|
||
' 模块：数据存档模块
|
||
' 功能：将[货期检查]中“修正交货日期”不为空的数据，追加到存档工作簿中
|
||
'=============================================================================
|
||
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 |