如果程序由Button-Click运行，则WS.SaveAs将变慢

我正在用Excelmacros为工作簿中的每个工作表创build.CSV文件。 这一切工作正常，如果我通过单击开发器选项卡中的macros运行macros并从那里运行macros。

如果我从Excel文件中的Form-Button运行macros，它会为每个Worksheet创build一个CSV文件，但是没有内容。

这里的VBA代码：

'This method generates CSV-Files for every Worksheet in a Workbook. Sub BtnGenerateCSV_click() Dim WS As Excel.Worksheet Dim SaveToDirectory As String Dim intResult As Integer On Error GoTo Heaven 'Disable all for my script unnecessary things. Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False 'Opens a file dialog for choosing the destination folder intResult = Application.FileDialog(msoFileDialogFolderPicker).Show If intResult <> 0 Then 'If a selection was made, the selected path is saved into this variable. SaveToDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\" For Each WS In ThisWorkbook.Worksheets If WS.Name = "Wegleitung" Or startsWith(WS.Name, "Hilfstabelle") Then 'Do Nothing because these Worksheets are just helping tables and not used data. Else 'Saving the Worksheet as a CSV to the chosen path with the name of the Worksheet. WS.SaveAs SaveToDirectory & WS.Name, xlCSV End If Next ThisWorkbook.Close End If 'Enable all these for my script unnecessary things. Finally: Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True 'Error-Handling Heaven: MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _ "Source: " & Err.Source & " " & vbCrLf & _ "Number: " & Err.Number & " " & vbCrLf & _ "Description: " & Err.Description & " " & vbCrLf End Sub 'This mmethod checks if a String starts with a specific other String. Public Function startsWith(str As String, prefix As String) As Boolean startsWith = Left(str, Len(prefix)) = prefix End Function 

我不确定这个问题的真正原因，但是我认为它必须用这个方法来做一些事情，这个方法太慢了，不能完成它的任务，并被一些事情打断。 我认为这是因为它有足够的时间来创build文件，但不填充数据。

我试图在SaveAs之后使用方法DoEvents，但是这不起作用。 另外，我试图禁用应用程序上的事件，我认为这也是中断SaveAs方法的可能原因。

最后，我读了很多Stackoverflow的问题，解决了创buildCSV文件的Excel文件的任务，但是我没有find这个问题的答案。 我希望这不是重复的，但如果是的话，请纠正我。

感谢您的帮助提前！

Answer 1

几件事。

1. 而不是startsWith(WS.Name, "Hilfstabelle")你可以使用Like运算符。 例如Like "Hilfstabelle*" 。 这种方式你不需要使用一个单独的function。
2. 您需要在Heaven:之前退出代码Heaven:
3. 试试下面提到的这个代码。 我没有testing过。 如果您遇到任何问题，请告诉我。

码：

 Sub BtnGenerateCSV_click() Dim WS As Worksheet Dim SaveToDirectory As String Dim intResult As Integer On Error GoTo Heaven With Application .ScreenUpdating = False .DisplayAlerts = False End With intResult = Application.FileDialog(msoFileDialogFolderPicker).Show If intResult <> 0 Then SaveToDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\" For Each WS In ThisWorkbook.Worksheets If WS.Name = "Wegleitung" Or WS.Name Like "Hilfstabelle*" Then Else WS.Copy ActiveWorkbook.SaveAs Filename:=SaveToDirectory & WS.Name & ".csv", FileFormat:=xlCSV ActiveWorkbook.Close savechanges:=False End If Next End If Finally: With Application .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "Done" Exit Sub Heaven: MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _ "Source: " & Err.Source & " " & vbCrLf & _ "Number: " & Err.Number & " " & vbCrLf & _ "Description: " & Err.Description & " " & vbCrLf Resume Finally End Sub