时间戳

首页 > 解决方案 > 打开另存为对话框并在取消时退出

excel - 打开另存为对话框并在取消时退出

问题描述

我正在创建一个自动购买请求，用户可以在其中提出购买请求，当他单击按钮时，将弹出另存为对话框并允许用户将文件保存在所需位置，然后增加 RTP 编号和关闭 Excel 工作表。下面是我的代码：

Sub sbUnProtectSheet()
Worksheets("RTP").Unprotect "123"
End Sub
Sub sbProtectSheet()
Worksheets("RTP").Protect "123", True, True
End Sub

Sub PostToRegister()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("RTP")
Set WS2 = Worksheets("Register")
nextrow = WS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
WS2.Cells(nextrow, 1).Resize(1, 7).Value = Array(WS1.Range("P8"), WS1.Range("P7"), WS1.Range("P10"), WS1.Range("P11"), WS1.Range("L9"), WS1.Range("TOT"), WS1.Range("P9"))
End Sub
Sub nextRTP()
Call sbUnProtectSheet
Sheets("RTP").Range("P7").Value = Sheets("RTP").Range("P7").Value + 1
Range("B15:O26").ClearContents
Sheets("RTP").Range("E8:I8").ClearContents
Sheets("RTP").Range("P9:P10").ClearContents
Sheets("RTP").Range("L7:L9").ClearContents
Sheets("RTP").Range("C32:I35").ClearContents
Sheets("RTP").Range("B38:P40").ClearContents
Sheets("RTP").CheckBoxes.Value = False
Call sbProtectSheet
End Sub

Sub SaveRTPWithNewName()
 Dim USERRESPONSE As Boolean
    USERRESPONSE = Application.Dialogs(xlDialogSaveAs).Show(PDFfileName, 52)
If WorksheetFunction.CountA(Sheets("RTP").Cells(8, "E"), Sheets("RTP").Cells(7, "L"), Sheets("RTP").Cells(8, "L"), Sheets("RTP").Cells(9, "L"), Sheets("RTP").Cells(9, "P"), Sheets("RTP").Cells(10, "P"), Sheets("RTP").Cells(38, "B")) = "7" Then

If WorksheetFunction.CountA(Sheets("RTP").Cells(15, "B"), Sheets("RTP").Cells(15, "C"), Sheets("RTP").Cells(15, "E"), Sheets("RTP").Cells(15, "M"), Sheets("RTP").Cells(15, "N"), Sheets("RTP").Cells(15, "O")) = "6" Then

Call sbUnProtectSheet
'PostToRegister
Call Save_Workbook_As_PDF
If USERRESPONSE = False Then
MsgBox ("you clicked no!")
Exit Sub
End If

nextRTP
Call sbProtectSheet
ActiveWorkbook.Save
ActiveWorkbook.Close
Else: MsgBox "NO ITEM INPUT RECEIVED. ENTER ALEAST ONE ITEM TO RAISE RTP"
End If
Else: MsgBox "ENTER ALL DETAILS TO RAISE RTP"
End If
End Sub

Public Sub Save_Workbook_As_PDF()

    Dim i As Integer, PDFindex As Integer
    Dim PDFfileName As String
   
       
    With ActiveWorkbook
        PDFfileName = "RTP " & Range("P7").Value & ".pdf"
    End With
    
    With Application.FileDialog(msoFileDialogSaveAs)
  
   
    PDFindex = 0
      For i = 1 To .Filters.Count
        If InStr(VBA.UCase(.Filters(i).Description), "PDF") > 0 Then PDFindex = i
       Next

        .Title = "Save workbook as "
        .InitialFileName = PDFfileName
        .FilterIndex = PDFindex
                If .Show Then
         
           Worksheets("RTP").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfileName, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
               
                End If
        
                       
    End With
    
End Sub

问题是，即使用户单击取消，代码继续运行并将 rtp # 增加 2，我希望代码在用户单击取消时退出......任何线索？

标签： excelvba

解决方案

这可以帮助您...专注于您拥有的部分 If .Show

With Application.FileDialog(msoFileDialogSaveAs)
    If .Show <> 0 Then
        'continue
    Else
        'enable events and screen updating
        Exit Sub
        'or you can use End instead of Exit Sub (depends on how you are nesting your procedures)
    End If
End With

编辑：

发布我的答案后，我注意到您在“SaveRTPWithNewName”中要求某种用户响应。因此，我将您的 Save_Workbook_As_PDF 转换为 Function 而不是 Sub，并且该函数返回 boolean = true 或 false。见 2 修改程序。

Sub SaveRTPWithNewName()
 Dim USERRESPONSE As Boolean
    USERRESPONSE = Application.Dialogs(xlDialogSaveAs).Show(PDFfileName, 52)
If WorksheetFunction.CountA(Sheets("RTP").Cells(8, "E"),     Sheets("RTP").Cells(7, "L"), Sheets("RTP").Cells(8, "L"), Sheets("RTP").Cells(9, "L"), Sheets("RTP").Cells(9, "P"), Sheets("RTP").Cells(10, "P"),     Sheets("RTP").Cells(38, "B")) = "7" Then

If WorksheetFunction.CountA(Sheets("RTP").Cells(15, "B"), Sheets("RTP").Cells(15, "C"), Sheets("RTP").Cells(15, "E"), Sheets("RTP").Cells(15, "M"), Sheets("RTP").Cells(15, "N"), Sheets("RTP").Cells(15, "O")) = "6" Then

Call sbUnProtectSheet
'PostToRegister

If Save_Workbook_As_PDF = False Then
MsgBox ("you clicked no!")
Exit Sub
End If

nextRTP
Call sbProtectSheet
ActiveWorkbook.Save
ActiveWorkbook.Close
Else: MsgBox "NO ITEM INPUT RECEIVED. ENTER ALEAST ONE ITEM TO RAISE RTP"
End If
Else: MsgBox "ENTER ALL DETAILS TO RAISE RTP"
End If
End Sub

Public Function Save_Workbook_As_PDF() As Boolean

Dim i As Integer, PDFindex As Integer
Dim PDFfileName As String

   
With ActiveWorkbook
    PDFfileName = "RTP " & Range("P7").Value & ".pdf"
End With

With Application.FileDialog(msoFileDialogSaveAs)


PDFindex = 0
  For i = 1 To .Filters.Count
    If InStr(VBA.UCase(.Filters(i).Description), "PDF") > 0 Then PDFindex = i
   Next

    .Title = "Save workbook as "
    .InitialFileName = PDFfileName
    .FilterIndex = PDFindex
            
            If .Show <> 0 Then
                Save_Workbook_As_PDF = True
     
       Worksheets("RTP").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfileName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
            Else
                Save_Workbook_As_PDF = False
            End If
    
                   
End With

End Function

当您需要从过程中检索 1 个结果时，最好使用函数代替 Subs。当您需要更多结果时，您应该使用在程序头中定义的参数和 ByRef...

希望这可以帮助

推荐阅读