Excel VBA表单保存校验文件名与指定单元格值一致性避免覆盖问题咨询

核心修改逻辑 #

在原有保存流程前新增文件名校验规则：

• 仅对已经保存过的文件做校验，首次保存的新模板文件不触发校验
• 提取当前工作簿不含后缀的文件名，与Home!B2单元格的命名值做比对
• 比对不一致时弹出告警，终止后续保存操作，同时自动恢复工作表保护状态
• 修复原代码中PDF导出路径后缀错误问题（原代码错误使用.xlsm作为PDF文件后缀，导致导出文件无法正常打开）

完整修改后代码 #

Private Sub cmdEnter_Click()
    'Unprotect QCS sheet
    Sheets("QCS").Unprotect Password:="1234"
    
    'Copy input values to sheet QCS
    Dim lRow As Long
    Dim ws As Worksheet
    Set ws = Worksheets("QCS")
    lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    With ws
        .Cells(lRow, 1).Value = Range("Home!B1")
        .Cells(lRow, 2).Value = Range("Home!B2")
        .Cells(lRow, 3).Value = Range("Home!B4")
        .Cells(lRow, 4).Value = Range("Home!B3")
        .Cells(lRow, 5).Value = Me.txtRollNumber.Value
        .Cells(lRow, 6).Value = Me.cboTreatment.Value
        .Cells(lRow, 7).Value = Me.cboTensions.Value
        .Cells(lRow, 8).Value = Me.txtWidth.Value
        .Cells(lRow, 9).Value = Me.txtBasisWeight.Value
        .Cells(lRow, 10).Value = Me.txtSlip.Value
        .Cells(lRow, 11).Value = Me.txtHaze.Value
        .Cells(lRow, 12).Value = Me.txtOpacity.Value
        .Cells(lRow, 13).Value = Me.txtGloss.Value
        
    End With
    'Clear input controls.
    Me.txtRollNumber.Value = ""
    Me.cboTreatment.Value = ""
    Me.cboTensions.Value = ""
    Me.txtWidth.Value = ""
    Me.txtBasisWeight.Value = ""
    Me.txtSlip.Value = ""
    Me.txtHaze.Value = ""
    Me.txtOpacity.Value = ""
    Me.txtGloss.Value = ""
    
    'Save the Workbook as excel doc.
    Application.DisplayAlerts = False
    Dim Path As String
    Dim filename As String
    Path = "C:\Users\121375\Documents\QCSTrial\"
    filename = Range("Home!B2")
    
    ' 新增：文件名校验逻辑
    Dim currentFileName As String
    ' 仅对已保存过的文件做校验，新文件首次保存不校验
    If ActiveWorkbook.Path <> "" Then
        ' 提取当前工作簿不含后缀的名称
        currentFileName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
        ' 名称不一致时终止保存
        If currentFileName <> filename Then
            MsgBox "当前文件名称与命名单元格值不一致，禁止保存！请确认后重试。", vbExclamation, "保存校验失败"
            ' 恢复工作表保护、关闭表单后退出
            Sheets("QCS").Protect Password:="1234"
            Unload Me
            Exit Sub
        End If
    End If
    
    ActiveWorkbook.SaveAs filename:=Path & filename & ".xlsm"
    
    'Save QCS Sheet as PDF
    'Create and assign variables
    Dim saveLocation As String
    Dim sheetArray As Variant

    ' 修复：PDF文件后缀修改为.pdf
    saveLocation = "C:\Users\121375\Documents\QCSTrial\" & filename & ".pdf"
    sheetArray = Array("QCS")

    'Select specific sheets from workbook, the save all as PDF
    Sheets(sheetArray).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
    filename:=saveLocation
    
    'Close Form.
    Unload Me
    
    'Protect Sheet Again.
    Sheets("QCS").Protect Password:="1234"
    
End Sub

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