VBA msgbox vbyesno to continue with current script

C

ClarityNDT

New Member
Joined
Mar 25, 2020
Messages
12
Office Version
  1. 2013
Platform
  1. Windows
Good afternoon.

I'm having some issues with a script that does some checking of a sheet prior to running a save operation. I have included the entire script for reference.

Code: 
Sub QCCheck()
Dim QC1 As String
Dim QC2 As String
Dim QC3 As String
Dim QC4 As String
Dim QC5 As String
Dim QC6 As String
Dim QC7 As String
Dim QC8 As String
Dim QC9 As String
Dim qc10 As String

Dim FileName As String
Dim path As String
Dim Cust As String
Dim pdfpath As String
'recalculate the entire sheet
ActiveSheet.Calculate

'Recalculates the QC fields to ensure they're up to date
Range("V1:V25").Calculate

'set the QC check cells
QC1 = Range("V13").Value
QC2 = Range("V14").Value
QC3 = Range("V15").Value
QC4 = Range("V16").Value
QC5 = Range("V17").Value
QC6 = Range("V18").Value
QC7 = Range("v19").Value
QC8 = Range("v20").Value
QC9 = Range("v21").Value
qc10 = Range("V22").Value

'set the variables
FileName = Range("v8").Value
path = "R:\"
Cust = Range("v11")
pdfpath = "R:\"

'Starts checking the document
If QC1 <> "0" Then
MsgBox ("Please review results sheet and complete all required fields")
Exit Sub
Else
If QC2 <> "0" Then
MsgBox ("Please select a customer.")
Exit Sub
Else
If QC3 <> "0" Then
MsgBox ("Previous revision does not exist. Please check revision status and details")
Exit Sub
Else
If QC4 <> "0" Then
MsgBox ("Please check technique revision status.")
Exit Sub
Else
If QC5 <> "0" Then
MsgBox ("Please complete revision details.")
Exit Sub
Else
If QC6 <> "0" Then
    If MsgBox("File already exists. Would you like to replace the existing file?", vbYesNo) = vbNo Then
    Exit Sub
Else
If QC7 <> "0" Then
MsgBox ("Please check created date in results sheet")
Exit Sub
Else
If QC8 <> "0" Then
MsgBox ("Please check report dates in results sheet")
Exit Sub
Else
If QC9 <> "0" Then
MsgBox ("Coverage is incorrect please check and try again")
Exit Sub
Else
If qc10 <> "0" Then
MsgBox ("Coverage is incorrect, please check and try again")
Exit Sub
Else

'We've checked the file for errors, now lets check that a directory exists and create it if it doesn't.

If Len(Dir(pdfpath & Cust, vbDirectory)) = 0 Then
MkDir (pdfpath & Cust)
End If

'Now call the sub routine for saving the file as excel
Call saveexcelcreatepdf

'Now give the user the option to print
'Call print_list

'time to close off all the if statements from the QC checks. Make sure there are enough!

'QC1
End If
'QC2
End If
'QC3
End If
'QC4
End If
'QC5
End If
'QC6
End If
'QC7
End If
'QC8
End If
'QC9
End If
'QC10
End If

'close off the save file loop
End If

'final refresh of the QC cells incase someone tries to click save again
Range("V1:V25").Calculate

'copy paste source data to allow easy edits on next revision
Worksheets("resultssheet").Range("T2:BH149").Copy
Worksheets("resultssheet").Range("T2:BH149").PasteSpecial xlPasteValues

'clear clipboard
Application.CutCopyMode = False

End Sub

The script checks the values of a set range of cells per worksheet to detect errors on a user completed form before saving and publishing as a pdf.

Firstly, apologies for my crude copy/paste building of this code :)

I'm having a specific issue with this section:

Code: 
If QC6 <> "0" Then
    If MsgBox("File already exists. Would you like to replace the existing file?.", vbYesNo) = vbNo Then
    Exit Sub
Else

This file is checking to see if the proposed filename already exists, and if it does I need the user to be able to make a choice on overwriting it or cancelling the script. However currently when yes is clicked nothing happens.

I would like this to continue on with the script and check the remaining QC fields then run the save script but cannot figure out why it wont.

Any clues?

TIA
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Edit:
Code: 
'close off the save file loop
End If
has been removed as I was trying something else.
 
Upvote 0
Try it like
VBA Code: 
Sub QCCheck()
Dim QC1 As String
Dim QC2 As String
Dim QC3 As String
Dim QC4 As String
Dim QC5 As String
Dim QC6 As String
Dim QC7 As String
Dim QC8 As String
Dim QC9 As String
Dim qc10 As String

Dim FileName As String
Dim path As String
Dim Cust As String
Dim pdfpath As String
'recalculate the entire sheet
ActiveSheet.Calculate

'Recalculates the QC fields to ensure they're up to date
Range("V1:V25").Calculate

'set the QC check cells
QC1 = Range("V13").Value
QC2 = Range("V14").Value
QC3 = Range("V15").Value
QC4 = Range("V16").Value
QC5 = Range("V17").Value
QC6 = Range("V18").Value
QC7 = Range("v19").Value
QC8 = Range("v20").Value
QC9 = Range("v21").Value
qc10 = Range("V22").Value

'set the variables
FileName = Range("v8").Value
path = "R:\"
Cust = Range("v11")
pdfpath = "R:\"

'Starts checking the document
If QC1 <> "0" Then
   MsgBox ("Please review results sheet and complete all required fields")
   Exit Sub
ElseIf QC2 <> "0" Then
   MsgBox ("Please select a customer.")
   Exit Sub
ElseIf QC3 <> "0" Then
   MsgBox ("Previous revision does not exist. Please check revision status and details")
   Exit Sub
ElseIf QC4 <> "0" Then
   MsgBox ("Please check technique revision status.")
   Exit Sub
ElseIf QC5 <> "0" Then
   MsgBox ("Please complete revision details.")
   Exit Sub
ElseIf QC6 <> "0" Then
    If MsgBox("File already exists. Would you like to replace the existing file?", vbYesNo) = vbNo Then Exit Sub
ElseIf QC7 <> "0" Then
   MsgBox ("Please check created date in results sheet")
   Exit Sub
ElseIf QC8 <> "0" Then
   MsgBox ("Please check report dates in results sheet")
   Exit Sub
ElseIf QC9 <> "0" Then
   MsgBox ("Coverage is incorrect please check and try again")
   Exit Sub
ElseIf qc10 <> "0" Then
   MsgBox ("Coverage is incorrect, please check and try again")
   Exit Sub
Else

   'We've checked the file for errors, now lets check that a directory exists and create it if it doesn't.
   
   If Len(Dir(pdfpath & Cust, vbDirectory)) = 0 Then
      MkDir (pdfpath & Cust)
   End If
   
   'Now call the sub routine for saving the file as excel
   Call saveexcelcreatepdf

'Now give the user the option to print
'Call print_list

'time to close off all the if statements from the QC checks. Make sure there are enough!

End If

'final refresh of the QC cells incase someone tries to click save again
Range("V1:V25").Calculate

'copy paste source data to allow easy edits on next revision
Worksheets("resultssheet").Range("T2:BH149").Copy
Worksheets("resultssheet").Range("T2:BH149").PasteSpecial xlPasteValues

'clear clipboard
Application.CutCopyMode = False

End Sub
 
Upvote 0
What a logical way of looking at it.

TYVM.

and thanks for tidying up the code too :)
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0
HI Fluff,

I'm still having an issue with this, when the file already exists the prompt comes up as per the code above however the call saveexcelcreatepdf doesn't seem to execute.

The copy / paste routines further down the code do execute, and I'm not receiving a debug error it just doesn't seem to run that external routine.

I can alt+f11 and manually launch the saveexcelcreatepdf routing and it will save and overwrite.

Any clues?
 
Upvote 0
Code: 
Sub QCCheck()
Dim QC1 As String
Dim QC2 As String
Dim QC3 As String
Dim QC4 As String
Dim QC5 As String
Dim QC6 As String
Dim QC7 As String
Dim QC8 As String
Dim QC9 As String
Dim qc10 As String

Dim FileName As String
Dim path As String
Dim Cust As String
Dim pdfpath As String
'recalculate the entire sheet
ActiveSheet.Calculate

'Recalculates the QC fields to ensure they're up to date
Range("V1:V25").Calculate

'set the QC check cells
QC1 = Range("V13").Value
QC2 = Range("V14").Value
QC3 = Range("V15").Value
QC4 = Range("V16").Value
QC5 = Range("V17").Value
QC6 = Range("V18").Value
QC7 = Range("v19").Value
QC8 = Range("v20").Value
QC9 = Range("v21").Value
qc10 = Range("V22").Value

'set the variables
FileName = Range("v8").Value
path = "R:\"
Cust = Range("v11")
pdfpath = "R:\"

'Starts checking the document
If QC1 <> "0" Then
   MsgBox ("Please review results sheet and complete all required fields")
   Exit Sub
ElseIf QC2 <> "0" Then
   MsgBox ("Please select a customer.")
   Exit Sub
ElseIf QC3 <> "0" Then
   MsgBox ("Previous revision does not exist. Please check revision status and details")
   Exit Sub
ElseIf QC4 <> "0" Then
   MsgBox ("Please check technique revision status.")
   Exit Sub
ElseIf QC5 <> "0" Then
   MsgBox ("Please complete revision details.")
   Exit Sub
ElseIf QC6 <> "0" Then
    If MsgBox("File already exists. Would you like to replace the existing file?", vbYesNo) = vbNo Then Exit Sub
ElseIf QC7 <> "0" Then
   MsgBox ("Please check created date in results sheet")
   Exit Sub
ElseIf QC8 <> "0" Then
   MsgBox ("Please check report dates in results sheet")
   Exit Sub
ElseIf QC9 <> "0" Then
   MsgBox ("Coverage is incorrect please check and try again")
   Exit Sub
ElseIf qc10 <> "0" Then
   MsgBox ("Coverage is incorrect, please check and try again")
   Exit Sub
Else

   'We've checked the file for errors, now lets check that a directory exists and create it if it doesn't.
   
   If Len(Dir(pdfpath & Cust, vbDirectory)) = 0 Then
      MkDir (pdfpath & Cust)
   End If
   
   'Now call the sub routine for saving the file as excel
   Call saveexcelcreatepdf

'Now give the user the option to print
'Call print_list

'time to close off all the if statements from the QC checks. Make sure there are enough!

End If

'final refresh of the QC cells incase someone tries to click save again
Range("V1:V25").Calculate

'copy paste source data to allow easy edits on next revision
Worksheets("resultssheet").Range("T2:BH149").Copy
Worksheets("resultssheet").Range("T2:BH149").PasteSpecial xlPasteValues

'clear clipboard
Application.CutCopyMode = False

End Sub

Code: 
Sub saveexcelcreatepdf()
Dim path As String
Dim FileName As String

path = "R:\"
FileName = Range("V8").Value & ".xlsm" 'sets the filename as the value of cell V8 and sets the extension
ActiveWorkbook.SaveAs path & FileName, xlOpenXMLWorkbookMacroEnabled 'selects the file format

'now create the pdf. the Filename range selects the cell contents as the filename, note this is an absolute path and extension in this case.
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Range("V7").Value, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub

current version of both routines for reference.
 
Upvote 0
Ok, how about
VBA Code: 
Sub QCCheck()
Dim QC1 As String
Dim QC2 As String
Dim QC3 As String
Dim QC4 As String
Dim QC5 As String
Dim QC6 As String
Dim QC7 As String
Dim QC8 As String
Dim QC9 As String
Dim qc10 As String

Dim FileName As String
Dim path As String
Dim Cust As String
Dim pdfpath As String
'recalculate the entire sheet
ActiveSheet.Calculate

'Recalculates the QC fields to ensure they're up to date
Range("V1:V25").Calculate

'set the QC check cells
QC1 = Range("V13").Value
QC2 = Range("V14").Value
QC3 = Range("V15").Value
QC4 = Range("V16").Value
QC5 = Range("V17").Value
QC6 = Range("V18").Value
QC7 = Range("v19").Value
QC8 = Range("v20").Value
QC9 = Range("v21").Value
qc10 = Range("V22").Value

'set the variables
FileName = Range("v8").Value
path = "R:\"
Cust = Range("v11")
pdfpath = "R:\"

'Starts checking the document
If QC1 <> "0" Then
   MsgBox ("Please review results sheet and complete all required fields")
   Exit Sub
ElseIf QC2 <> "0" Then
   MsgBox ("Please select a customer.")
   Exit Sub
ElseIf QC3 <> "0" Then
   MsgBox ("Previous revision does not exist. Please check revision status and details")
   Exit Sub
ElseIf QC4 <> "0" Then
   MsgBox ("Please check technique revision status.")
   Exit Sub
ElseIf QC5 <> "0" Then
   MsgBox ("Please complete revision details.")
   Exit Sub
ElseIf QC6 <> "0" Then
    If MsgBox("File already exists. Would you like to replace the existing file?", vbYesNo) = vbNo Then Exit Sub
ElseIf QC7 <> "0" Then
   MsgBox ("Please check created date in results sheet")
   Exit Sub
ElseIf QC8 <> "0" Then
   MsgBox ("Please check report dates in results sheet")
   Exit Sub
ElseIf QC9 <> "0" Then
   MsgBox ("Coverage is incorrect please check and try again")
   Exit Sub
ElseIf qc10 <> "0" Then
   MsgBox ("Coverage is incorrect, please check and try again")
   Exit Sub
End If

   'We've checked the file for errors, now lets check that a directory exists and create it if it doesn't.
   
   If Len(Dir(pdfpath & Cust, vbDirectory)) = 0 Then
      MkDir (pdfpath & Cust)
   End If
   
   'Now call the sub routine for saving the file as excel
   Call saveexcelcreatepdf

'Now give the user the option to print
'Call print_list

'time to close off all the if statements from the QC checks. Make sure there are enough!


'final refresh of the QC cells incase someone tries to click save again
Range("V1:V25").Calculate

'copy paste source data to allow easy edits on next revision
Worksheets("resultssheet").Range("T2:BH149").Copy
Worksheets("resultssheet").Range("T2:BH149").PasteSpecial xlPasteValues

'clear clipboard
Application.CutCopyMode = False

End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

V
  • Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
70
VanGirl
V
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
243
Peter_SSs
Peter_SSs
M
  • Question
Add in VBA Code to check zip code against pre-determined list
Replies
0
Views
156
mikefisher
M
rjplante
  • Solved
Change from Set as Default to Set as Active printer
Replies
1
Views
219
NdNoviceHlp
NdNoviceHlp
A
  • Question
Moving Rows Up (Scroll) To Defined Row Number for Viewing
Replies
6
Views
199
Ark68
A

Forum statistics

Threads
1,215,046
Messages
6,122,855
Members
449,096
Latest member
Erald

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top