Excel VBA“自动化错误：调用的对象已与其客户端断开连接”

Excel VBA "Automation Error: Object Invoked has disconnected from its clients"

提问by xlJunkie

I figured out what Nick was suggesting, and the following is the error number & description that I'm getting:

我想出了尼克的建议，以下是我得到的错误编号和描述：

'-2147417848 (80010108)' Automation error The object invoked has disconnected from its clients

“-2147417848 (80010108)”自动化错误调用的对象已与其客户端断开连接

The line of code that is highlighted when I debug is:

调试时突出显示的代码行是：

.Rows(Lst).Insert Shift:=xlDown

.Rows(Lst).Insert Shift:=xlDown

I thought that I had seen somewhere on this or another forum to unregister then re-register a specific file, but I was at home when I came across that, and didn't want to try it on my laptop, since everything already works 100% on it.

我以为我在这个或其他论坛上的某个地方看到过注销然后重新注册特定文件，但是当我遇到那个时我在家，不想在我的笔记本电脑上尝试它，因为一切都已经正常工作 100 ％ 在上面。

Once again, any help is greatly appreciated. I leave Sunday for 2 weeks, and I really need to get this working before I leave. Most of the people working for me are not excel guru's and need all buttons/functions working, as they won't be able to troubleshoot and/or work around the problems.

再次，非常感谢任何帮助。我周日离开 2 周，我真的需要在离开之前让这个工作正常进行。对我来说有效的大多数人都不是优秀的大师，需要所有按钮/功能都能正常工作，因为他们将无法排除故障和/或解决问题。

I am still sitting with the following code in a regular module, and the next set of code below that is in one of the worksheet modules.

我仍然在常规模块中使用以下代码，而下面的下一组代码位于其中一个工作表模块中。

 Sub add_InvRow()
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False

 switch = "off"

 With ThisWorkbook
  Dim wb As Excel.Workbook, Lst As Long
  Set wb = Application.ThisWorkbook
Dim ws As Worksheet, sw As Worksheet, os As Worksheet
   Set ws = ActiveSheet: Set sw = Application.Sheets(Sheet1.Name): Set os = Application.Sheets(Sheet4.Name)

  With ws
  Lst = ActiveCell.Row
  End With

   If ws.CodeName = "Sheet3" Then

  With os
   .Rows(213).Copy
  End With

  With ws


   .Rows(Lst).Insert Shift:=xlDown
   Application.CutCopyMode = False

    venTabForm.Show
  End With
End If

If ws.CodeName = "Sheet23" Then

  With sw
   .Rows(135).Copy
  End With

  With ws

   .Rows(Lst).Insert Shift:=xlDown
   Application.CutCopyMode = False

    cItemForm.Show
  End With
End If

 If ws.CodeName = "Sheet25" Then

 With sw
   .Rows(105).Copy
  End With

  With ws

   .Rows(Lst).Insert Shift:=xlDown
   Application.CutCopyMode = False

   coInvForm.Show
  End With
 End If

 If ws.CodeName = "Sheet28" Then

  With sw
   .Rows(100).Copy
  End With

  With ws

   .Rows(Lst).Insert Shift:=xlDown
   Application.CutCopyMode = False

   kInvForm.Show
  End With
End If

If ws.CodeName = "Sheet27" Then

  With sw
   .Rows(130).Copy
  End With

  With ws
     .Rows(Lst).Insert Shift:=xlDown
     Application.CutCopyMode = False

     ItemForm.Show
  End With
End If

If ws.CodeName = "Sheet22" Then

  With sw
   .Rows(120).Copy
  End With

  With ws

   .Rows(Lst).Insert Shift:=xlDown
   Application.CutCopyMode = False

    caInvForm.Show
  End With
End If

 Set ws = Nothing: Set sw = Nothing: Set os = Nothing: Set wb = Nothing
End With

 switch = "on"
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
End Sub

This code is on one of the worksheets that has a command button, which calls the above code.

此代码位于具有调用上述代码的命令按钮的工作表之一上。

 Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If switch = "off" Then Exit Sub
 If Target.Address = "$H" Then
  Call findItem
 Exit Sub
 End If


If Application.Intersect(Target, Me.Range("P:P")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If Target.Cells.Value = 0 Or Target.Cells.Value = "" Then Exit Sub
Dim wb As Workbook, ws As Worksheet, iNUM As String, kitSHT As Worksheet, ksRNG As Range, kITEM As Range, kbCELL As Range
Dim iNAME As String, catSHT As Worksheet, csRNG As Range, cbCELL As Range, cITEM As Range
Dim logCELL As Range



Set wb = ThisWorkbook: Set ws = wb.Sheets(Sheet27.Name): Set kitSHT = wb.Sheets(Sheet28.Name): Set catSHT = wb.Sheets(Sheet22.Name)
Set ksRNG = kitSHT.Range("C5:C1100"): Set kbCELL = ksRNG.Cells(5, 3)
Set csRNG = catSHT.Range("C6:C400"): Set cbCELL = csRNG.Cells(6, 3)


 If (Not (Application.Intersect(Target, Me.Range("A:P")) Is Nothing)) And (Target.Cells.Count = 1) And (Target.Column = 16) Then
  If Target.Value = 0 Then Exit Sub
   iNUM = Target.Offset(, -12).Value
   iNAME = Target.Offset(, -10).Value

   If kitSHT.Cells.Find(What:=iNUM, After:=kbCELL, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) Is Nothing And _
  catSHT.Cells.Find(What:=iNUM, After:=cbCELL, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) Is Nothing Then



    MsgBox iNUM & "-" & iNAME & "" & " is not currently listed on" & " " & kitSHT.Name & " " & "or" & " " & catSHT.Name & vbNewLine & vbNewLine & _
              "Please add" & " " & iNUM & "-" & iNAME & "" & " to" & " " & kitSHT.Name & " " & _
               "or" & " " & catSHT.Name & " " & "and corresponding count sheets", vbInformation

  Set wb = Nothing: Set ws = Nothing: Set kbCELL = Nothing
  Set ksRNG = Nothing: Set kitSHT = Nothing: Set cbCELL = Nothing: Set catSHT = Nothing: Set csRNG = Nothing
  Exit Sub
 Else
If Target.Value = 0 Then Exit Sub
  premNUM = iNUM


 pFORM.Show
 End If
 End If

  Set wb = Nothing: Set ws = Nothing: Set kbCELL = Nothing
  Set ksRNG = Nothing: Set kitSHT = Nothing: Set cbCELL = Nothing: Set catSHT = Nothing: Set csRNG = Nothing


  Set ksRNG = Nothing: Set kitSHT = Nothing: Set cbCELL = Nothing: Set catSHT = Nothing: Set csRNG = Nothing
End Sub

回答by xlJunkie

Ok... It's been well over 1 month now, and I've finally fixed this!! Fortunately & Unfortunately, it had absolutely nothing to do with my code. Instead, it was an MS Office Vs. Windows 8 problem. To fix it, I ran the compatability troubleshooter, and all is back to perfect again:

好的...现在已经超过 1 个月了，我终于解决了这个问题！！幸运的是，不幸的是，它与我的代码完全无关。相反，它是一个 MS Office Vs。Windows 8 问题。为了修复它，我运行了兼容性疑难解答，一切又恢复了完美：

1. Open MS Excel (Any File or new file)
2. Pull up Task Manager
3. Click on MS Office or Excel Icon in Background Processes, Right click, and select properties
4. Under Compatibility, Click "Run Compatibility Troubleshooter"
5. When finished running, test file again, if it works right, click apply settings to this program. If it doesn't work, click next and choose from the options. (I chose that it worked in previous version of Windows (Windows 7) Then click Next again.
6. Test file again, and it worked.

1. 打开 MS Excel（任何文件或新文件）
2. 调出任务管理器
3. 单击后台进程中的 MS Office 或 Excel 图标，右键单击并选择属性
4. 在兼容性下，单击“运行兼容性疑难解答”
5. 运行完成后，再次测试文件，如果正常，请单击将设置应用到此程序。如果它不起作用，请单击下一步并从选项中进行选择。（我选择它在以前版本的 Windows (Windows 7) 中工作）然后再次单击下一步。
6. 再次测试文件，它起作用了。

I cannot believe that this is all I had to do the whole time! I actually spent $149 thinking that Microsoft Support could remote in and fix it, but that was an absolute waste! I was transferred to 12+ different people/departments, and still got nothing from them. I finally stumbled across the solution this morning....

我简直不敢相信这就是我一直以来要做的一切！我实际上花了 149 美元以为 Microsoft 支持可以远程访问并修复它，但这绝对是浪费！我被调到了 12 多个不同的人/部门，但仍然一无所获。今天早上我终于偶然发现了解决方案......

Anyway, thanks to everyone who posted and tried to help me with this. I always log off of this site with better VBA skills than I signed on with because of all of you... So Thanks again!

无论如何，感谢所有发布并试图帮助我解决这个问题的人。因为你们所有人，我总是以比我登录时更好的 VBA 技能注销这个站点......所以再次感谢！

回答by Shakeit

This solution works for me:

这个解决方案对我有用：

Before adding rows with Shift:=xlDown delete bottom rows on the worksheet

在使用 Shift:=xlDown 添加行之前删除工作表上的底部行

'ADD THE ROWS YOU WANT

Sheets("XXXXXX").Range("A100000:A100100").EntireRow.Delete

With Selection
.Copy
.Insert Shift:=xlDown
End With

回答by Rajeev

Make sure your sheet is not protected with cells locked while doing insert. This could be one of the reason why the code will fail. This code was working for me on one folder, but when I copied the excel macro file to another folder I started getting this error. Since it is only for formatting, I avoided using the below codes altogether and did formatting the usual way and not copying from above rows. Note that in first code, entire row gets selected and if you have protected cells, it could lead to failure.
'Rows(r + 3 & ":" & r + 3).Select 'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

确保您的工作表在插入时不受锁定单元格的保护。这可能是代码失败的原因之一。这段代码在一个文件夹上对我有用，但是当我将 excel 宏文件复制到另一个文件夹时，我开始收到此错误。由于它仅用于格式化，我完全避免使用以下代码，而是按照通常的方式进行格式化，而不是从上面的行复制。请注意，在第一个代码中，整行都被选中，如果您有受保护的单元格，则可能会导致失败。
'Rows(r + 3 & ":" & r + 3).Select 'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

回答by Dumitru Daniel

I had the same issue, with some macros that were working for everyone but not 1 person.

我遇到了同样的问题，有些宏适用于所有人，但不适用于 1 个人。

I solved it by asking the person to not use a folder that was synced to OneDrive, so be careful when using OneDrive.

我通过要求此人不要使用同步到 OneDrive 的文件夹解决了这个问题，因此在使用 OneDrive 时要小心。

I had other cases where OneDrive marked downloaded files from BOX or other file sharing services as read only, and made macros error out. And all you would need to do is open the file, save it and open it up again, but allot of people blamed it on my macros. It took me a while to find the cause, and to find a way to save an reopen the file using macros, before it actually opens...

我还有其他情况，其中 OneDrive 将从 BOX 或其他文件共享服务下载的文件标记为只读，并导致宏出错。您需要做的就是打开文件，保存并再次打开它，但是很多人将其归咎于我的宏。我花了一段时间才找到原因，并在文件实际打开之前找到了一种使用宏保存重新打开文件的方法......