I have written code to record all changes to a worksheet then email these changes to an email address. I am using the ThisWorkbook SheetChange and Before close events to do this. The code I have submitted is the sub that is getting called in the Before close event. I am getting this Runtime error 9 when no changes are done to the workbook. I have recently learned about the events on the thisWorkbook workbook, this is my first time using them in a project. The error is on the line wrkbkSrc.Worksheets(strSheetName).Cells.Copy. (Highlighted in red) After doing some research I read about writing a global procedure but I have never done that before, so I don't know where to start. I know where the error is but if no changes were made I would want to go to skipworksheet. If that is the solution I would appreciate anyone's help in resolving this.
Rich (BB code):
Public Sub EmailChanges()
Dim xlApp As Object
Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim wrkbkSrc As Workbook
Dim wrkbkDest As Workbook
Dim strSheetName As String
Dim wrksh As Worksheet
Dim lRow As Long
Dim strEMailAddress As String
Dim strLastSheet As String
Dim lngX As Long
Dim lngLastSheet As Long
Dim strFileName As String
Dim strUserName As String
Dim strDirName As String
Dim strFolderName As String
Dim NewBook As Excel.Workbook
Dim strDestWrkSh As String
Dim strFullName_sp As String
Dim strWrbkName As String
Dim wrkShChecked As Excel.Worksheet
Dim lngLoop As Long
Dim strCheckSheet As String
Dim boolProcessed As Boolean
Dim lngWrkShCnt As Long
Dim boolStartedXL As Boolean
'Turn off calculations so sheet wont use CalculatePremium function
Application.Calculation = xlCalculationManual
'Turn off events so the sheetchange does not get used when not needed
Application.EnableEvents = False
'Turn off Alerts
Application.DisplayAlerts = False
'Turn off Screenupdating
Application.ScreenUpdating = True
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
boolStartedXL = True
End If
Set wrkbkSrc = ThisWorkbook
Set wrksh = ActiveSheet
'Get Sheet Name
strLastSheet = Sheets(Sheets.Count).Name
If strLastSheet = "Sheet1" Then GoTo SkipWorkSheet
'Define Sheet names
strSheetName = "LogDetails"
strFileName = "LogDetails.xlsm"
strDestWrkSh = "Details"
strWrbkName = wrkbkSrc.Name
'Determine directory of user
strUserName = Environ("username")
'Determine Folder of user to put file into
strFolderName = "\\citrixuser\Prodfoldredir$\" & strUserName & "\Documents\"
'Determine if user is a Laptop user or a citrix user
FolderExists (strFolderName)
If FolderExists(strFolderName) = True Then
strFolderName = "\\citrixuser\Prodfoldredir$\" & strUserName & "\Documents\"
Else
strFolderName = "C:\Users\" & strUserName & "\Documents\"
End If
strDirName = strFolderName & "LogDetails.xlsm"
'Delete LogDetails.xlsm if it exists
If Dir(strDirName) = "" Then
Else
Kill strDirName
End If
'Create a temporary LogDetails workbook in the users My Documents directory
Set wrkbkDest = Workbooks.Add
With wrkbkDest
'Name worksheet
.Sheets("Sheet1").Name = strDestWrkSh
'Delete sheets that are not needed from new workbook
.Sheets("Sheet2").Delete
.Sheets("Sheet3").Delete
End With
'Copy the LogDetails sheet from the Gears workbook and save to a temporary workbook
'Verify LogDetails Exists (If no changes were made it wont exist)
lngWrkShCnt = ActiveWorkbook.Worksheets.Count
For lngLoop = lngWrkShCnt To 1 Step -1
Set wrkShChecked = Worksheets(lngLoop)
strCheckSheet = wrkShChecked.Name
'If sheet exists set boolean to true and skip procedure
If strCheckSheet = "LogDetails" Then
GoTo WorksheetFound
Else
End If
Next lngLoop
WorksheetFound:
wrkbkSrc.Worksheets(strSheetName).Cells.Copy
'Paste into temporary LogDetails sheet
With wrkbkDest
.Sheets(strDestWrkSh).Range("A1").PasteSpecial xlPasteAll
'Format temporary LogDetails sheet
.Sheets(strDestWrkSh).Columns("A:E").AutoFit
.Sheets(strDestWrkSh).Columns("A:E").Cells.HorizontalAlignment = xlHAlignLeft
'Save temporary LogDetails sheet to users My Documents Directory
.SaveAs Filename:=strDirName, FileFormat:=52
End With
'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
'Set mail attributes
strEMailAddress = "PM_RTA_Prod_Support@LibertyMutual.com"
'Function to email
With oMail
.To = strEMailAddress
.Subject = "Changes from " & strWrbkName & " " & strSheetName
.Body = "Changes from " & strWrbkName & " have been recorded " & vbCrLf & vbCrLf & _
"Attached is the file"
.Attachments.Add wrkbkDest.FullName
.Send
End With
'Delete LogDetails Sheet in Gears Manual workbook
wrkbkSrc.Sheets(strSheetName).Delete
'Close Gears Manual Workbook
wrkbkDest.Close SaveChanges:=False
'Delete LogDetails Workbook
Kill strDirName
SkipWorkSheet:
'Turn Functions on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
'Clear objects
Set oMail = Nothing
Set oApp = Nothing
Set wrkShChecked = Nothing
Set wrkbkDest = Nothing
Set wrkbkSrc = Nothing
Set xlApp = Nothing
ThisWorkbook.Save
If boolStartedXL Then Application.Quit
End Sub
