Excel VBA运行错误1004 MaxVal+1工单号提交后不递增故障

安全阿岳

2026-8-30

Excel VBA 周期校验自动化脚本 1004错误/工单编号不递增故障修复

问题描述

开发Excel VBA脚本实现周期校验表单自动化处理，VBA掌握程度有限，已定位到故障发生环节但无修复方案，运行时报错错误代码1004。
故障现象：第一份PDF文件生成后，工作簿无法正常保存，工单编号始终停留在Ticket# 1无法正常递增。

脚本预期实现功能

表单填写完成后，将相关校验数据复制到独立存储工作簿
向相关责任人发送新校验记录提交的通知邮件
将当前校验记录导出保存为PDF文件
重置表单内容，将工单编号设置为MaxVal + 1，用于下一次校验记录填报

原始问题代码

Application.ScreenUpdating = False
If Range("H3").Value = "" Then MsgBox "Please Enter Device Serial Number"
Range("H3").Select
If Range("H3").Value = "" Then Exit Sub
If Range("M3").Value = "" Then MsgBox "Please Enter Reference Standard ID"
Range("M3").Select
If Range("M3").Value = "" Then Exit Sub
If Range("K9").Value = "" Then MsgBox "Please Enter Atleast One Dimensional Check"
Range("K9").Select
If Range("K9").Value = "" Then Exit Sub
If Range("Q9").Value = "" Then MsgBox "Please Enter Visual Check for Damage"
Range("Q9").Select
If Range("Q9").Value = "" Then Exit Sub
If Range("U9").Value = "" Then MsgBox "Please Enter Inital for Damage Check"
Range("U9").Select
If Range("U9").Value = "" Then Exit Sub
If Range("Q10").Value = "" Then MsgBox "Please Enter Visual Check for Wear"
Range("Q10").Select
If Range("Q10").Value = "" Then Exit Sub
If Range("U10").Value = "" Then MsgBox "Please Enter Inital for Wear Check"
Range("U10").Select
If Range("U10").Value = "" Then Exit Sub
If Range("Q11").Value = "" Then MsgBox "Please Enter Visual Check for Travel"
Range("Q11").Select
If Range("Q11").Value = "" Then Exit Sub
If Range("U11").Value = "" Then MsgBox "Please Enter Inital for Travel Check"
Range("U11").Select
If Range("U11").Value = "" Then Exit Sub
If Range("Q12").Value = "" Then MsgBox "Please Enter Visual Check for Zero"
Range("Q12").Select
If Range("Q12").Value = "" Then Exit Sub
If Range("U12").Value = "" Then MsgBox "Please Enter Inital for Zero Check"
Range("U12").Select
If Range("U12").Value = "" Then Exit Sub
If Range("Q13").Value = "" Then MsgBox "Please Enter Visual Check for Repeatability"
Range("Q13").Select
If Range("Q13").Value = "" Then Exit Sub
If Range("U13").Value = "" Then MsgBox "Please Enter Inital for Repeatability Check 3x"
Range("U13").Select
If Range("U13").Value = "" Then Exit Sub
If Range("C23").Value = "True" Then MsgBox "Please Check Final Verification Pass or Fail"
If Range("C23").Value = "True" Then Exit Sub
Workbooks.Open "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\VerificationData(DONOTDELETE).xlsx"
Application.Run (["GetMax"])
Application.Run (["SavePrintEmail"])
Application.Run (["CopyClear"])
Application.ScreenUpdating = True
End Sub
Private Sub GetMax()
Dim WorkRange As Range
Dim MaxVal As Double
Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
Set WorkRange = ActiveWorkbook.Worksheets("Data").Range("AK:AK")
MaxVal = WorksheetFunction.Max(WorkRange)
Workbooks("PIV-001.xlsm").Activate
ActiveWorkbook.Worksheets("PIV-001").Unprotect ("Moldamatic")
ActiveWorkbook.Worksheets("PIV-001").Range("U21").Value = MaxVal + 1
End Sub
Private Sub SavePrintEmail()

    ThisWorkbook.Save
    
  If Len(Dir("\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date), vbDirectory)) = 0 Then
        MkDir "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date)
        End If
          
     
 
Sheets("PIV-001").Select
   

    Sheets("PIV-001").ExportAsFixedFormat xlTypePDF, "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date) & "\" & Range("U21").Value & "-" & Year(Date), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


Dim OutApp As Object
Dim OutMail As Object
    
  
 
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)



On Error Resume Next
With OutMail
    .To = "Spage@moldamatic.com"
    .CC = ""
    .BCC = ""
    .Subject = "NEW INSTRUMENT VERFICATION (TICKET# " & Range("U21").Value & " INSTRUMENT ID# " & Range("H3").Value & " RESULT: " & Range("H22").Value & ")"
    .HTMLBody = "An instrument has just been verfied, please see attached verification report. Verficiation results:  " & Range("H22").Value & " "
    .Attachments.Add "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date) & "\" & Range("U21").Value & "-" & Year(Date) & ".pdf"
    .send
    End With



On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

    ThisWorkbook.Save
    
    End Sub
Private Sub CopyClear()
    'Change path to database in line below
    Dim historyWks As Worksheet
    Dim inputWks As Worksheet

    Dim nextRow As Long
    Dim oCol As Long

    Dim myRng As Range
    Dim myCopy As String
    Dim myCell As Range
   
    
    'cells to copy from Input sheet - some contain formulas
    myCopy = "U21,C22,E22,H3,M3,B9,F9,I9,K9,B10,F10,I10,K10,B11,F11,I11,K11,B12,F12,I12,K12,B13,F13,I13,K13,Q9,U9,Q10,U10,Q11,U11,Q12,U12,Q13,U13,G17"

    Set inputWks = ThisWorkbook.Worksheets("PIV-001")
    Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
    Set historyWks = ActiveWorkbook.Worksheets("Data")

    With historyWks
        nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    End With

    With inputWks
        Set myRng = .Range(myCopy)
    End With
    
    With historyWks
    With .Cells(nextRow, "A")
            .Value = Now
            .NumberFormat = "mm/dd/yyyy hh:mm:ss"
        End With
        .Cells(nextRow, "B").Value = Application.UserName
        oCol = 3
        For Each myCell In myRng.Cells
            historyWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
    Workbooks("PIV-001.xlsm").Activate
    Range("H3,M3,B9,F9,K9,B10,F10,K10,B11,F11,K11,B12,F12,K12,B13,F13,K13,Q9,U9,Q10,U10,Q11,U11,Q12,U12,Q13,U13,G17").Select
    Selection.ClearContents
    ActiveSheet.CheckBoxes.Value = False
    Range("H3:L3").Select
    ThisWorkbook.Worksheets("PIV-001").Protect ("Moldamatic")
    Workbooks("PIV-001.xlsm").Save
    Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
    Workbooks("VerificationData(DONOTDELETE).xlsx").Save
    Workbooks("VerificationData(DONOTDELETE).xlsx").Close
End Sub

故障根因

核心逻辑错误（工单编号不递增的直接原因）
复制表单数据到存储工作簿时，工单编号U21是复制列表的第一个字段，从存储表C列（第3列）开始写入，最终落在C列；但GetMax函数读取最大值的列是AK列，AK列始终没有写入过有效工单编号，WorksheetFunction.Max对空列返回0，因此每次计算得到的新工单编号永远是0+1=1。
1004错误触发原因
代码大量依赖Activate/Select切换活动工作簿、工作表，所有Range调用都没有显式指定父对象，跨工作簿操作时一旦活动对象不符合预期，就会触发range引用失败的1004错误；同时PDF导出文件名未显式添加.pdf后缀，部分Excel环境下会生成无后缀文件，后续添加邮件附件时找不到对应文件也会触发报错。
流程顺序漏洞
当前执行顺序是「打开存储表→计算新工单号→生成PDF/发邮件→写入数据到存储表→清空表单」，如果写入存储表环节因为网络盘断开、文件被占用失败，新工单号不会被持久化存储，下次运行依然会拿到旧的最大值。

修复方案

修正列映射：调整GetMax函数的读取列为实际存储工单编号的列（即当前写入的C列），或调整数据写入的起始列，保证工单编号写入后能被Max函数正确读取。
调整执行顺序：先完成数据写入存储表、保存存储表，确认写入成功后再生成PDF、发送邮件，最后计算下一个工单编号、清空表单。
移除所有不必要的Activate/Select操作，所有单元格、工作表、工作簿对象都显式指定所属父对象，避免活动对象切换导致的引用错误。
给PDF导出文件名显式添加.pdf后缀，工作表解锁和保护操作配对，避免保护状态下操作单元格触发权限错误。
移除无差别吞错误的On Error Resume Next，给邮件发送、网络盘操作添加明确的错误提示，不要静默忽略故障。

修复后核心代码片段（关键逻辑调整）

' 调整后执行顺序：校验输入→打开存储表→写入当前记录→保存存储表→计算新工单号→导出PDF发邮件→清空表单
Private Function GetMax(historyWks As Worksheet) As Double
    ' 直接传入存储表工作表对象，不需要激活工作簿
    ' 修正取值列为实际存储工单编号的C列
    GetMax = WorksheetFunction.Max(historyWks.Range("C:C"))
End Function

' PDF导出补全后缀
Sheets("PIV-001").ExportAsFixedFormat xlTypePDF, _
    "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date) & "\" & inputWks.Range("U21").Value & "-" & Year(Date) & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

内容的提问来源于stack exchange，提问作者sebastian page

Excel VBA运行错误1004 MaxVal+1工单号提交后不递增故障

问题描述 #

脚本预期实现功能 #

原始问题代码 #

故障根因 #

修复方案 #