BeforeSave 事件不工作
BeforeSave Event not working
我正在尝试将数据导出到 csv 并在保存 excel 文件时发送,但它不起作用。当在保存事件中未设置为 运行 时,代码本身 运行 完全没问题。
任何帮助将不胜感激
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveSheet.Unprotect
ActiveSheet.Range(":8").AutoFilter Field:=2
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Workbooks.Add
Application.DisplayAlerts = False
ChDir "F:\Customer Services\Returns"
ActiveWorkbook.SaveAs Filename:="F:\Customer Services\Returns\Credits.csv", _
FileFormat:=xlCSV, CreateBackup:=False
Range("A1").Select
Windows("Credits 2017.xlsm").Activate
Selection.Copy
Windows("Credits.csv").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("S:U").Select
Selection.Delete Shift:=xlToLeft
Application.DisplayAlerts = True
Dim xOutApp As Object
Dim xMailItem As Object
Dim xName As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xName = ActiveWorkbook.FullName
With xMailItem
.To = "Email address"
.CC = ""
.Subject = "Credits"
.Body = "Hi," & Chr(13) & Chr(13) & "File is now updated."
.Attachments.Add xName
.Display = False
.send
End With
Set xMailItem = Nothing
Set xOutApp = Nothing
Windows("Credits.csv").Activate
ActiveWorkbook.Close SaveChanges = True
Windows("Credits 2017.xlsm").Activate
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
ActiveWorkbook.Close SaveChanges = True
End Sub
试试这个:
- 制作第一行(在
Sub
下方)Application.EnableEvents = False
- 制作最后一行(在
End Sub
之上) Application.EnableEvents = True
我正在尝试将数据导出到 csv 并在保存 excel 文件时发送,但它不起作用。当在保存事件中未设置为 运行 时,代码本身 运行 完全没问题。 任何帮助将不胜感激
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveSheet.Unprotect
ActiveSheet.Range(":8").AutoFilter Field:=2
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Workbooks.Add
Application.DisplayAlerts = False
ChDir "F:\Customer Services\Returns"
ActiveWorkbook.SaveAs Filename:="F:\Customer Services\Returns\Credits.csv", _
FileFormat:=xlCSV, CreateBackup:=False
Range("A1").Select
Windows("Credits 2017.xlsm").Activate
Selection.Copy
Windows("Credits.csv").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("S:U").Select
Selection.Delete Shift:=xlToLeft
Application.DisplayAlerts = True
Dim xOutApp As Object
Dim xMailItem As Object
Dim xName As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xName = ActiveWorkbook.FullName
With xMailItem
.To = "Email address"
.CC = ""
.Subject = "Credits"
.Body = "Hi," & Chr(13) & Chr(13) & "File is now updated."
.Attachments.Add xName
.Display = False
.send
End With
Set xMailItem = Nothing
Set xOutApp = Nothing
Windows("Credits.csv").Activate
ActiveWorkbook.Close SaveChanges = True
Windows("Credits 2017.xlsm").Activate
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
ActiveWorkbook.Close SaveChanges = True
End Sub
试试这个:
- 制作第一行(在
Sub
下方)Application.EnableEvents = False
- 制作最后一行(在
End Sub
之上)Application.EnableEvents = True