VBA打开保存窗口，尽管事件和警报关闭

Question

我所要做的就是将工作簿中的一个工作表保存到同一文件夹中的新工作簿中。

但是每次我运行代码时，excel都会中断执行并打开另存为窗口，在这里您必须选择文件夹和文件名称，这是我以前从未见过的。

关于如何规避这个问题有什么想法吗?我关闭了事件和提醒。

代码:

Sub Export_Data()
Dim ws As Worksheet, wb As Workbook
Dim name As String
Dim lcol As Double, lrow As Double
Dim path As String
Set ws = ThisWorkbook.Worksheets("EMPLOYEES")
Application.DisplayAlerts = False
Application.EnableEvents = False
path = "C:UsersPATH"
Set wb = Workbooks.Add
ws.Copy Before:=wb.Sheets(1)
On Error Resume Next ' Need this because I get a runtime error 1004, though it still saves it regardless
wb.SaveAs Filename:=path & "People_Data" & ".xlsx", FileFormat:=51 '''' Here is where it opens the save as window??????
wb.Sheets("Sheet1").Delete
wb.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Answer 1

另存工作表到新工作簿

• 如果没有别的，这应该能说明发生了什么。期待您的反馈。

Sub SaveWorksheetToNewWorkbook()
Const ProcName As String = "SaveWorksheetToNewWorkbook"
Dim Success As Boolean
On Error GoTo ClearError

Const SOURCE_WORKSHEET_NAME As String = "EMPLOYEES"
Const DESTINATION_FOLDER_PATH As String = "C:Test"
Const DESTINATION_FILE_NAME As String = "People_Data.xlsx"

Application.ScreenUpdating = False

' Check if the destination path exists.

Dim pSep As String: pSep = Application.PathSeparator

Dim dFolderPath As String: dFolderPath = DESTINATION_FOLDER_PATH
If Right(dFolderPath, 1) <> pSep Then dFolderPath = dFolderPath & pSep

Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
If Len(dFolderName) = 0 Then
MsgBox "The path '" & dFolderPath & "' doesn't exist.", _
vbExclamation, ProcName
Exit Sub
End If

Dim dwb As Workbook

' Check if the destination workbook, or a workbook with the same name,
' is open.

On Error Resume Next
Set dwb = Workbooks(DESTINATION_FILE_NAME)
On Error GoTo ClearError
If Not dwb Is Nothing Then
If StrComp(dwb.Path & pSep, dFolderPath, vbTextCompare) = 0 Then
MsgBox "The destination workbook '" & DESTINATION_FILE_NAME _
& "' is open." & vbLf & "Close it and try again.", _
vbExclamation, ProcName
Else
MsgBox "A workbook with the same name as the destination file ('" _
& DESTINATION_FILE_NAME & "') is open." _
& vbLf & "Close it and try again.", vbExclamation, ProcName
End If
Exit Sub
End If

' Export the worksheet.

Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets(SOURCE_WORKSHEET_NAME)

sws.Copy ' creates a copy as a new single-worksheet workbook

Set dwb = Workbooks(Workbooks.Count)

Dim ErrNumber As Long
Dim ErrDescription As String

Application.DisplayAlerts = False ' overwrite without confirmation
On Error Resume Next
dwb.SaveAs dFolderPath & DESTINATION_FILE_NAME
ErrNumber = Err.Number
ErrDescription = Err.Description
On Error GoTo ClearError
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False ' just got saved

If ErrNumber <> 0 Then
MsgBox "' Run-time error '" & ErrNumber & "':" & vbLf _
& ErrDescription & vbLf & vbLf _
& "This error occurred while attempting to save the workbook.", _
vbCritical, ProcName
Exit Sub
End If

Success = True

ProcExit:
On Error Resume Next
If Success Then
MsgBox "Worksheet saved to new workbook.", vbInformation, ProcName
End If
On Error GoTo 0

Exit Sub
ClearError:
MsgBox "' Run-time error '" & Err.Number & "':" & vbLf _
& Err.Description & vbLf & vbLf _
& "This error occurred quite unexpectedly.", _
vbCritical, ProcName 
Resume ProcExit
End Sub