关于excel：Application.InputBox error 424 on cancel

Application.InputBox error 424 on cancel

我正在使用一个调用输入框的 sub 来从工作表中复制选定的单元格并将它们粘贴到多列列表框中。我终于让一切正常工作，除了用户取消输入框时出现错误 424。我已经阅读了无数关于此错误的帮助线程，但没有发现任何似乎能够为我处理该错误的内容。我希望有人可以告诉我下面的代码是否有问题(除了 1200 万次退出子尝试停止错误)，或者可能让我了解另一个领域(声明、初始化、激活？)我应该检查一下。任何想法表示赞赏，谢谢。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

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 代码的尝试：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

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

相关讨论

从 Dirk\\'s final post here 中找到了解决方案。对于任何有兴趣的人，这里是工作代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

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