Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
Sub submit()
Application.ScreenUpdating = False
If Not IsFileOpen("file path QA Database.xls") Then
Workbooks.Open "file path QA Database.xls"
End If
Workbooks("QA Database.xls").Activate
Workbooks("QA Database.xls").Worksheets("Database").Select
ActiveSheet.Unprotect ("password goes here")
Windows("QA.xls").Activate
ActiveSheet.Unprotect ("password here")
If MsgBox("Choose OK to submit these results to the database. Please 'RESET' the form before resubmitting another check. If this form says changes have been made to the Database, select keep changes and then resubmit", vbOKCancel) = vbOK Then
Application.EnableEvents = False
If Range("Z17").Value = "1" Then
MsgBox "Data already copied to QA log"
Exit Sub
End If
Range("Z17") = 0
If Range("B4").Value = "" Then
MsgBox "Please Enter Case owner name"
Exit Sub
End If
If Range("B5").Value = "" Then
MsgBox "Please Enter reference"
Exit Sub
End If
If Range("B6").Value = "" Then
MsgBox "Please Enter Outcome Date"
Exit Sub
End If
If Range("D4").Value = "" Then
MsgBox "Please Enter your name"
Exit Sub
End If
If Range("C9").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C10").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C11").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C12").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C13").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C14").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C15").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C16").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C17").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C18").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C19").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C20").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C21").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
If Range("C22").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub
End If
Range("B4").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("B5").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("B7").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BC" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("D4").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BA" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("D5").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("B6").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("D6").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BB" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("A3").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C9").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C10").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("I" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C11").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("J" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C12").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C13").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("L" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C14").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("M" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C15").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("N" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C16").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("O" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C17").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("P" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C18").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("Q" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C19").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("R" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C20").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("S" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C21").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("T" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
Range("C22").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("U" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Windows("QA.xls").Activate
ChDir "File path"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="file path" & Range("B4").Value & Range("J5").Value & Range("B5").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Windows("QA Database.xls").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "Your scores have been successfully submitted!"
Application.EnableEvents = True
Else
Exit Sub
End If
End Sub
Sub SavePDF()
'
' SavePDF Macro
'
'
ChDir "file path"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Range("B4").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
End Sub
Bookmarks