取消文件对话框提示excel打开excel日志文件

Question

希望大家今天过得愉快。我的代码有问题。这里的代码将显示一个文件对话框并要求用户选择文件，效果很好。我的问题是，当它显示文件对话框时，我不想选择我想要的文件夹，而是点击取消。但是当我点击取消时，会出现运行时错误，提示“下标超出或范围”。它将打开一个标题为 ts-event.log 的 excel 文件

所以，我尝试通过使用错误处理 On Error GoTo 来解决这个问题。因此，我将得到一个消息框，而不是来自 VBA 的默认消息框，它显示“您取消了操作”。但我仍然打开了 ts-event.log excel 文件。我该如何避免这种情况？有人能帮我吗。提前谢谢你。

Sub UploadData()

Dim SummWb As Workbook
Dim SceWb As Workbook

'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    myFolderName = .SelectedItems(1)
    'Err.Clear
    On Error GoTo Error_handler
End With

If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
    'Settings
    Application.ScreenUpdating = False
    oldStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Set SummWb = ActiveWorkbook
    'Get source files and append to output file
    mySceFileName = Dir(myFolderName & "*.*")

        Do While mySceFileName <> "" 'Stop once all files found
            Application.StatusBar = "Processing: " & mySceFileName
            Set SceWb = Workbooks.Open(myFolderName & mySceFileName) 'Open file found
                With SummWb.Sheets("Master List")
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B1").Value
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B2").Value
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B3").Value
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B4").Value
                    .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C7").Value
                    .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D7").Value
                    .Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C8").Value
                    .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D8").Value
                    .Cells(.Rows.Count, "L").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C9").Value
                    .Cells(.Rows.Count, "M").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D9").Value
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = SummWb.Sheets("Upload Survey").Range("C8").Value
                End With
            SceWb.Close (False) 'Close Workbook
            mySceFileName = Dir

       Loop
Error_handler:
MsgBox ("You cancelled the action.")

MsgBox ("Upload complete.")

'Settings and save output file
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
SummWb.Activate
SummWb.Save 'save automaticallly
Application.ScreenUpdating = True

End Sub

Answer 1

取消不代表出错

Sub UploadData()

Dim SummWb As Workbook
Dim SceWb As Workbook
Dim myFolderName As String
Dim oldstatusbar As Boolean
Dim mySceFileName As String

On Error GoTo Error_handler
'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        .AllowMultiSelect = False
        myFolderName = .SelectedItems(1)
      Else 'You clicked cancel
        GoTo Cancel_handler
    End If
End With

If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
   'Settings
    Application.ScreenUpdating = False
    oldstatusbar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Set SummWb = ActiveWorkbook
    'Get source files and append to output file
    mySceFileName = Dir(myFolderName & "*.*")

        Do While mySceFileName <> "" 'Stop once all files found
            Application.StatusBar = "Processing: " & mySceFileName
            Set SceWb = Workbooks.Open(myFolderName & mySceFileName) 'Open file found
                With SummWb.Sheets("Master List")
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B1").Value
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B2").Value
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B3").Value
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B4").Value
                    .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C7").Value
                    .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D7").Value
                    .Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C8").Value
                    .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D8").Value
                    .Cells(.Rows.Count, "L").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C9").Value
                    .Cells(.Rows.Count, "M").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D9").Value
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = SummWb.Sheets("Upload Survey").Range("C8").Value
                End With
            SceWb.Close (False) 'Close Workbook
            mySceFileName = Dir

       Loop

  SummWb.Activate
  SummWb.Save 'save automaticallly
  MsgBox ("Upload complete.")
Finish:
  Application.StatusBar = False
  Application.DisplayStatusBar = oldstatusbar
  Application.ScreenUpdating = True
  Exit Sub
Cancel_handler:
  MsgBox "You cancelled the action."
  Exit Sub
Error_handler:
  MsgBox "An unexpected error occurred."
  GoTo Finish
End Sub

注意第一个Exit Sub：如果没有错误发生，这是程序将结束的地方。如果单击取消按钮，它将显示 msgbox 并在第二个 Exit Sub 处结束。但是，如果发生错误，您可以使用Goto Finish 将其带回，您可以在其中拥有将应用程序恢复到初始状态的所有语句。