Application.InputBox错误424取消
我正在调用一个input框从一个工作表复制选定的单元格,并将其粘贴到一个多列列表框。 我终于得到了一切正常工作, 除了错误424当用户取消input框。 我已经阅读了无数的帮助线程关于这个错误,并没有发现,似乎能够处理我的错误。 我希望有人可以告诉我,如果下面的代码有问题(除了1200万退出子试图阻止错误),或者可能给我一个另一个领域的想法(声明,初始化,激活?我应该检查。 任何想法表示赞赏,谢谢。
Private Sub CopyItemsBtn_Click() Dim x As Integer Dim rSelected As Range, c As Range Dim wb Dim lrows As Long, lcols As Long x = ProformaToolForm.ItemsLB.ListCount 'Prompt user to select cells for formula On Error GoTo cleanup wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*") If wb <> False Then Workbooks.Open wb End If Set rSelected = Application.InputBox(Prompt:= _ "Select cells to copy", _ Title:="Transfer Selection", Type:=8) If Err.Number = 424 Then Debug.Print "Canceled" Exit Sub ElseIf Err.Number <> 0 Then Debug.Print "unexpected error" Exit Sub End If If rSelected.Rows.Count < 1 Or rSelected.Columns.Count < 1 Then Exit Sub End If Err.Clear On Error GoTo 0 'Only run if cells were selected and cancel button was not pressed If Not rSelected Is Nothing Then For Each c In rSelected With ProformaToolForm.ItemsLB .AddItem .List = rSelected.Cells.Value End With Next Else Exit Sub End If cleanup: Exit Sub End Sub
经过一些清理,这是我的尝试与Tim的代码:
Private Sub CopyItemsBtn_Click() Dim rSelected As Range, c As Range Dim wb wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*") If wb <> False Then Workbooks.Open wb End If 'Prompt user to select cells for formula On Error Resume Next Set rSelected = Application.InputBox(Prompt:= _ "Select cells to copy", _ Title:="Transfer Selection", Type:=8) On Error GoTo 0 If rSelected Is Nothing Then MsgBox "no range selected", vbCritical Exit Sub End If For Each c In rSelected With ProformaToolForm.ItemsLB .AddItem .List = rSelected.Cells.Value End With Next End Sub
以下是我倾向于这样做的方式:
Private Sub CopyItemsBtn_Click() Dim rSelected As Range On Error Resume Next Set rSelected = Application.InputBox(Prompt:= _ "Select cells to copy", _ Title:="Transfer Selection", Type:=8) On Error GoTo 0 If rSelected Is Nothing Then MsgBox "no range selected!", vbCritical Exit Sub End If 'continue with rSelected End Sub
find了一个解决scheme,从德克的最后一篇文章。 对于任何有兴趣的人来说,这里是工作代码:
Private Sub CopyItemsBtn_Click() Dim rSelected As Range Dim wb Dim MyCol As New Collection wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*") If wb <> False Then Workbooks.Open wb End If MyCol.Add Application.InputBox(Prompt:= _ "Select cells to copy", _ Title:="Transfer Selection", Type:=8) If TypeOf MyCol(1) Is Range Then Set MyRange = MyCol(1) Set MyCol = New Collection If rSelected Is Nothing Then MsgBox "no range selected", vbCritical Exit Sub End If ProformaToolForm.ItemsLB.List = rSelected.Value End Sub