Hi Excel Experts,
I have a macro which update a pivot table and if there is a change in pivot table send an e-mail if not saved and closed workbook (the workbook is open automatically by windows scheduler).
The problem concern closing whole Excel 2013 window.
If there is no change in PT my workbook does not close and I see a grey window of excel and when there is a change after update and sending email, I see my pivot table in open workbook.
How sould I modified a code to closed workbook no meter if there is a change or no in PT.
Thanks for help !
Function WBcount() As Byte
WBcount = Application.Workbooks.Count
End Function
Private Sub Workbook_Open()
Dim RowNoB As Long
Dim RowNoA As Long
With ActiveSheet.PivotTables("Tabela przestawna1")
RowNoB = .TableRange2.Rows.Count
.PivotCache.Refresh
RowNoA = .TableRange2.Rows.Count
End With
Application.DisplayAlerts = False
If RowNoB = RowNoA Then
If Not WBcount = 1 Then
ThisWorkbook.Close True
Else
Application.Quit
End If
End If
Application.DisplayAlerts = True
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Deadline projektów " _
& Format(Now, "dd-mm-yyyy")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "mymail@.com"
.CC = ""
.BCC = ""
.Subject = "...."
.Body = "..."
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\Users\....")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Bookmarks