无处不在：应用程序定义的错误或对象定义的错误

我写了一个小的macros，将事务input到我们的ERP系统中，当确定电子表格中定义的第二个位置是否大于零时，事情似乎会被抹黑。 这是我的代码：

Option Explicit Sub DblChk() If (MsgBox("Are you sure you are ready to append scrap data to QAD? This cannot be reversed.", vbOKCancel)) = 1 Then Call Scrap Else: Exit Sub End If End Sub Sub Scrap() On Error GoTo ErrorHelper Sheets("Roundup").Select Range("I2").Select Call Shell("C:\Program Files\QAD\QAD Enterprise Applications 2.9.6\QAD.Applications.exe", vbNormalFocus) 'Sign in to QAD Application.Wait (Now + TimeValue("0:00:05")) SendKeys ("username") SendKeys ("{TAB}") SendKeys ("password") SendKeys ("{ENTER}") 'Enter Scrap Application.Wait (Now + TimeValue("0:00:15")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) 'Scrap Loop Do While Not IsEmpty(ActiveCell) If ActiveCell.Value > 0 Then ActiveCell.Offset(0, -8).Activate SendKeys (ActiveCell.Value) ActiveCell.Offset(0, 6).Activate SendKeys ("{ENTER}") SendKeys (ActiveCell.Value) SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) ActiveCell.Offset(0, -1).Activate SendKeys (ActiveCell.Value) SendKeys ("{ENTER}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("SCRAP") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) ActiveCell.Offset(0, 2).Activate SendKeys (ActiveCell.Value) SendKeys ("{TAB}") ActiveCell.Offset(0, -4).Activate SendKeys (ActiveCell.Value) SendKeys ("{TAB}") ActiveCell.Offset(0, 1).Activate SendKeys (ActiveCell.Value) SendKeys ("{ENTER}") SendKeys ("{ENTER}") ActiveCell.Offset(1, -4).Activate Else ActiveCell.Offset(1, 0).Activate End If Loop ErrorHelper: MsgBox Err.Description End Sub 

我在互联网上看到了这个错误的几个引用，但似乎没有适用于我的具体情况。 If语句开始时似乎会出错。

有什么想法吗？

Answer 1

我已经对你的代码做了一些调整（见代码中的注释）

 Sub DblChk() Rem This line is enough anything else is redundant If MsgBox("Are you sure you are ready to append scrap data to QAD? This cannot be reversed.", vbOKCancel) = 1 Then Call Scrap End Sub 

这是你的代码修改，注意使用声明的variables，它仍然显示原始行“评论”

一般的假设是Offset命令总是引用这一行中的ActiveCell ：

Do While Not IsEmpty(ActiveCell)取代这个Do While rCll.Value2 <> Empty

请注意在ErrorHelper行之前添加了Exit Sub行，否则即使没有错误，也会始终显示错误消息。

 Sub Scrap() Dim rCll As Range On Error GoTo ErrorHelper '' Sheets("Roundup").Select '' Range("I2").Select Set rCll = ThisWorkbook.Sheets("Roundup").Range("I2") 'If Procedure resides is Workbook with data 'Set rCll = Workbooks(WbkName).Sheets("Roundup").Range("I2") 'If Procedure does not reside is Workbook with data Call Shell("C:\Program Files\QAD\QAD Enterprise Applications 2.9.6\QAD.Applications.exe", vbNormalFocus) 'Sign in to QAD Application.Wait (Now + TimeValue("0:00:05")) SendKeys ("username") SendKeys ("{TAB}") SendKeys ("password") SendKeys ("{ENTER}") 'Enter Scrap Application.Wait (Now + TimeValue("0:00:15")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) 'Scrap Loop ' Do While Not IsEmpty(ActiveCell) Do While rCll.Value2 <> Empty Rem ActiveCell.Value2=empty is more accurate than IsEmpty(ActiveCell) With rCll If .Value2 > 0 Then ' ActiveCell.Offset(0, -8).Activate ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, -8).Value2) ' ActiveCell.Offset(0, 6).Activate SendKeys ("{ENTER}") ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, 6).Value2) SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) ' ActiveCell.Offset(0, -1).Activate ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, -1).Value2) SendKeys ("{ENTER}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("SCRAP") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) ' ActiveCell.Offset(0, 2).Activate ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, 2).Value2) SendKeys ("{TAB}") ' ActiveCell.Offset(0, -4).Activate ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, -4).Value2) SendKeys ("{TAB}") ' ActiveCell.Offset(0, 1).Activate ' SendKeys (ActiveCell.Value) SendKeys (.Offset(0, 1).Value2) SendKeys ("{ENTER}") SendKeys ("{ENTER}") ' ActiveCell.Offset(1, -4).Activate Set rCll = .Offset(1, -4) Else ' ActiveCell.Offset(1, 0).Activate rCll = .Offset(1, 0) End If: End With Loop Exit Sub ErrorHelper: MsgBox Err.Description End Sub 

但是，您可以通过早期识别和声明目标范围来避免使用Do … Loop

 Sub Scrap_Using_Range() Dim rTrg As Range Dim rCll As Range On Error GoTo ErrorHelper Set rCll = ThisWorkbook.Sheets("Roundup").Range("I2") 'If Procedure resides is Workbook with data 'Set rCll = Workbooks(WbkName).Sheets("Roundup").Range("I2") 'If Procedure does not reside is Workbook with data With rCll Set rTrg = IIf(.Offset(1, 0).Value2 = Empty, .Cells, Range(.Cells, .Cells.End(xlDown))) End With Call Shell("C:\Program Files\QAD\QAD Enterprise Applications 2.9.6\QAD.Applications.exe", vbNormalFocus) 'Sign in to QAD Application.Wait (Now + TimeValue("0:00:05")) SendKeys ("username") SendKeys ("{TAB}") SendKeys ("password") SendKeys ("{ENTER}") 'Enter Scrap Application.Wait (Now + TimeValue("0:00:15")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) 'Scrap Loop For Each rCll In rTrg With rCll If .Value2 > 0 Then SendKeys (.Offset(0, -8).Value2) SendKeys ("{ENTER}") SendKeys (.Offset(0, 6).Value2) SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys (.Offset(0, -1).Value2) SendKeys ("{ENTER}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys ("SCRAP") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") SendKeys ("{TAB}") Application.Wait (Now + TimeValue("0:00:01")) SendKeys (.Offset(0, 2).Value2) SendKeys ("{TAB}") SendKeys (.Offset(0, -4).Value2) SendKeys ("{TAB}") SendKeys (.Offset(0, 1).Value2) SendKeys ("{ENTER}") SendKeys ("{ENTER}") End If: End With: Next Exit Sub ErrorHelper: MsgBox Err.Description End Sub