[已解决]求助高手：Inputbox 取消问题

qdzhxg

Fanout(mpo)国内2012-5月制造管理台账.rar (31.37 KB, 下载次数: 8)

2012-5-8 13:03 上传

点击文件名下载附件 各位大侠：
       小弟在使用inputbox 时遇到一个问题，在提示框内正确输入数据时程序代码得以正常运行，但如果点击了取消按钮，则excel文档立即卡死。

       附件1中点击装箱单生成器运行程序，附件二是提取的数据存放的文件

最佳答案

月排行榜 / 总排行榜

zjdh

2012-5-8 14:28

把语句：
Application.Interactive = False
Application.Interactive = True
删除即可！

跳转到最佳答案楼层

qdzhxg

附件二如下，是用来存放从附件1的表格中提取的数据并做进一步处理，如需运行附件1中的程序，可能需要将两个附件都下载下来，并且在附件1的程序中改一下文件路径

qdzhxg

附件1中表格的密码为：123456

qdzhxg

附件1 中的代码如下：


Sub 装箱单()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Interactive = False
Dim lastrow As Long, finalrow As Long, nextcol As Long
Dim irange As Range, crange As Range, orange As Range
Dim sh1 As Worksheet, sh2 As Worksheet
Dim wbk As Workbook
Dim arr, str As String
On Error GoTo veryend
Set sh1 = ThisWorkbook.Sheets("FANOUT台账")
sh1.Activate
With sh1
finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row
nextcol = .Cells(2, Columns.Count).End(xlToLeft).Column + 2
.Cells(2, "k").Copy .Cells(1, nextcol)
str = InputBox("请输入日期", "生成装箱单")
If str = "" Then
.Cells(1, nextcol).Clear
Exit Sub
Else
.Cells(2, nextcol) = str
End If
Set crange = .Cells(1, nextcol).Resize(2, 1)
.Cells(1, nextcol + 2).Resize(1, 19).Value = _
Array(.Cells(2, "q"), .Cells(2, "l"), .Cells(2, "n"), .Cells(2, "u"), .Cells(2, "y"), .Cells(2, "b"), .Cells(2, "c"), _
.Cells(2, "d"), .Cells(2, "e"), .Cells(2, "f"), .Cells(2, "g"), .Cells(2, "a"), .Cells(2, "a"), .Cells(2, "a"), _
.Cells(2, "a"), .Cells(2, "a"), .Cells(2, "a"), .Cells(2, "x"), .Cells(2, "aa"))
Set orange = .Cells(1, nextcol + 2).Resize(1, 19)
Set irange = .Cells(2, 1).Resize(finalrow - 1, nextcol - 2)
irange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=crange, CopyToRange:=orange
lastrow = .Cells(Rows.Count, nextcol + 2).End(xlUp).Row
.Cells(2, "aw").Resize(lastrow - 1, 6).ClearContents
End With
Workbooks.Open "Z:\生产台帐\装箱单相关文件\PACKING LIST模板.xls"
Set wbk = ActiveWorkbook
wbk.Sheets("FANOUT").Activate
With wbk.Sheets("FANOUT")
arr = .Cells(16, "o").Resize(lastrow - 1, 3)
.Cells(16, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, 19).Clear
sh1.Cells(2, nextcol + 2).Resize(lastrow - 1, 19).Copy .Cells(16, 1)
.Cells(16, 1).Resize(lastrow - 1, 19).Sort key1:=Range("a1")
.Cells(16, 1).Resize(lastrow - 1, 19).Font.Size = 18
.Rows("16:80").RowHeight = 40
.Cells(16, "o").Resize(lastrow - 1, 3) = arr
.Cells(10, 13) = sh1.Cells(2, nextcol)
End With
sh1.Columns("AJ:BQ").Delete shift:=xlToLeft

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Interactive = True
veryend:
End Sub

qdzhxg

高手们，快出来啊，有人可以解答吗

qdzhxg

论坛好寂寞啊，有高手吗，求助啊

zjdh

把语句：
Application.Interactive = False
Application.Interactive = True
删除即可！

qdzhxg

问题解决，非常感谢