Application.InputBox 错误 424 取消

Question

我正在使用一个调用输入框的 sub 从工作表中复制选定的单元格并将它们粘贴到多列列表框中。我终于让一切正常工作，除了当用户取消输入框时出现错误 424。我已经阅读了无数关于此错误的帮助线程，但没有发现任何似乎能够为我处理该错误的内容。我希望有人可以告诉我下面的代码是否有问题（除了 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

Answer 1

从 Dirk 的最后一篇帖子 here 中找到了解决方案。对于任何有兴趣的人，这里是工作代码：

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

Answer 2

我倾向于这样做：

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