The object invoked has disconnected from its clients

[supercharger]

Hopefully an easy one. This is a code that seems to work most of the time, but will randomly throw up the error in the title. Code is below. It gives the error at the Selection.Insert Shift:=xlToRight line.

I'm in Excel 2016, I can only image that's what is causing this, but I'm not an expert by any means...which is why I'm here.

Any help is greatly appreciated!

Sub CommsPowerPoint()'
' CommsPowerPoint Macro
'


'
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    Columns("J:J").Select
    ActiveSheet.Unprotect "xxx"
    Selection.Cut
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    Columns("F:H").Select
    Selection.EntireColumn.Hidden = True
    Columns("J:M").Select
    Selection.EntireColumn.Hidden = True
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 1
    Range("A11:I107").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -13303610
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = -13303610
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A10:I10").Select
    Selection.AutoFilter
    Range("B11").Select
    ActiveSheet.Protect "xxx"
End Sub

 

[Fluff]

Cross posted https://www.excelforum.com/excel-pr...nvoked-has-disconnected-from-its-clients.html

Cross-Posting
While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[Norie]

Looks to me like recorded code, especially with all this type of stuff.

ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4

What is the code meant to do?

 

[supercharger]

Looks to me like recorded code, especially with all this type of stuff.

ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4

What is the code meant to do?

Thanks for the response. It is a recorded macro. What I'm doing is moving a column (J to B) and then hiding other columns. The objective is to allow users to copy and paste special in to a PowerPoint slide. The macro is executed with a button.

 

[JuanJoBF]

Hi All,

I know you are the best so I come for assistance in this particular issue. I´ll like to attach both files, can i do that here?. I don´t understand why am I getting the disconnected from its clients message and right after an Out of memory message. I´ve highlighted in blue where it fails.

My Code:

Public GetIBRFile As Variant
Public Lastr As Long
Public wbopen As Workbook
Public FilePath As String
Public sFileName As String
Public FileString As String
Public Last2 As Long
Public CRange As Range
Public CSUM As Long
Public i As Variant
Public Ibox As Integer
Public Sumrec As Integer
Public r As Long
Public y As Integer


Sub Phase1()


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Contract"
Sheets("Contract").Range("A1").Value = "Contract Number"
Sheets("Contract").Range("B1").Value = "Counter"
Sheets("Contract").Range("C1").Value = "Group #"
Sheets("Contract").Range("E1").Value = "Groups Consolidate"


Sheets("Contract").Columns("A:E").EntireColumn.AutoFit


GetIBRFile = _
Application.GetOpenFilename(FileFilter:="Excel Files (*.xls;*.xlsx;*.xlsm;*.xlsb;*.csv),*.xls;*.xlsx;*.xlsm;*.xlsb;*.csv", Title:="Open FIS File", MultiSelect:=False)
If GetIBRFile = False Then Exit Sub


FilePath = Left$(GetIBRFile, InStrRev(GetIBRFile, ""))
sFileName = Mid$(GetIBRFile, InStrRev(GetIBRFile, "") + 1)


Set wbopen = Workbooks.Open(GetIBRFile)


wbopen.Activate


Lastr = Range("A1000000").End(xlUp).Row


ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "IBR"


wbopen.ActiveSheet.Range("A1:AP" & Lastr).Copy Destination:=ThisWorkbook.Sheets("IBR").Range("A1")




With ThisWorkbook.Sheets("IBR").Cells
.Copy
.PasteSpecial xlPasteValues
.WrapText = False
.EntireColumn.AutoFit
End With


ThisWorkbook.Sheets("IBR").Activate
With ActiveWindow
.Zoom = 80
.DisplayGridlines = False
End With


Last2 = Sheets("IBR").Range("C999999").End(xlUp).Row
ThisWorkbook.Sheets("IBR").Range("A12").Comment.Delete
ThisWorkbook.Sheets("IBR").Range("J12").Comment.Delete




Sheets("IBR").Range("C13:C" & Lastr).Copy Destination:=Sheets("Contract").Range("A2")
Sheets("Contract").Select
Sheets("Contract").Range("A2", Range("A2").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo


wbopen.Close


Lastr = Sheets("Contract").Range("A999999").End(xlUp).Row


Range("B2:B" & Lastr).Formula = "=Countif(IBR!$C$13:$C$" & Last2 & ",Contract!A2)"
Range("B2:B" & Lastr).Copy
Range("B2:B" & Lastr).PasteSpecial xlPasteValues
Application.CutCopyMode = False


Call Inputbox


If r = vbCancel Then
Exit Sub
End If




If Application.WorksheetFunction.Sum(Range(Cells(2, 2), Cells(Lastr, 2))) <= Ibox Then
Range(Cells(2, 3), Cells(Lastr, 3)).Value = 1
'Cree un solo workbook
End If


y = 1


For i = 2 To Lastr
If Range("B" & i).Value >= Ibox Then
If Cells(i, 3).Value = "" Then
Range("C" & i).Value = "x"
End If
Sheets("Contract").Columns("C").Replace _
What:="x", Replacement:=y, _
SearchOrder:=xlByColumns, MatchCase:=False
y = y + 1
End If
Next


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


If Not Sheets("Contract").AutoFilterMode Then
Sheets("Contract").Range("A1").AutoFilter
End If


Columns("A:C").Sort key1:=Range("B1"), _
order1:=xlDescending, Header:=xlYes


For i = 2 To Lastr
Range("D1").Formula = "=SUMIFS(B2:B" & Lastr & ",C2:C" & Lastr & ",""x"")"
If Cells(i, 3) = "" Then
Cells(i, 3).Value = "x"
If Range("D1").Value > Ibox Then
Cells(i, 3).Value = ""
Sheets("Contract").Columns("C").Replace _
What:="x", Replacement:=y, _
SearchOrder:=xlByColumns, MatchCase:=False
y = y + 1
i = i - 1
End If
If i = Lastr Then
Sheets("Contract").Columns("C").Replace _
What:="x", Replacement:=y, _
SearchOrder:=xlByColumns, MatchCase:=False
Range("D1").ClearContents
Exit For
End If
End If
Next


Range("D1") = ""


Range("C2:C" & Lastr).Copy Destination:=Range("E2")
Range("E2:E" & Lastr).RemoveDuplicates Columns:=1, Header:=xlNo


'Last row groups without duplicates
Last2 = Range("E999999").End(xlUp).Row


Sumrec = Range("E" & Last2).Value
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Filtering"
Sheets("Contract").Select
CSUM = Sheets("IBR").Range("A999999").End(xlUp).Row


For i = Range("E2").Value To Sumrec
Sheets("Contract").Range("A2:C2" & Lastr).AutoFilter Field:=3, Criteria1:=i, _
Operator:=xlAnd
Range("A2:A" & Lastr).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Filtering").Range("A1")
If Not Sheets("IBR").AutoFilterMode Then
Sheets("IBR").Range("A12").AutoFilter
End If
Last2 = Sheets("Filtering").Range("A999999").End(xlUp).Row


Sheets("IBR").Range("$A$12:$AP$" & CSUM).AutoFilter Field:=3, Criteria1:=Sheets("Filtering").Range("A1:A" & Last2), Operator:=xlFilterValues


ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "NA Invoice Report Sample"
Sheets("IBR").Range("A1:AP" & CSUM).Copy Destination:=Sheets("NA Invoice Report Sample").Range("A1")
Columns("A:AP").EntireColumn.AutoFit
ThisWorkbook.Sheets("NA Invoice Report Sample").Copy
ActiveWorkbook.SaveAs Filename:=FilePath & Sheets("IBR").Range("A13").Value & " " & i
ActiveWorkbook.Close
Sheets("NA Invoice Report Sample").Delete
Sheets("Filtering").Range("A1").EntireColumn.ClearContents
Sheets("IBR").Select
Sheets("IBR").AutoFilter.ShowAllData
Sheets("Contract").Select
Sheets("Contract").AutoFilter.ShowAllData
Next


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True


End Sub
---------------------------------------------------------
Function Inputbox()
Dim Output As Integer


Inputbegin:


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


On Error GoTo ErrHandler:
Ibox = Application.Inputbox("Choose the maximum lines to split each IBR:", "Choose the Split Number", "Enter a number here")
If Ibox = False Then
Sheets("IBR").Delete
Sheets("Contract").Range("D1").ClearContents
Range("A2:B" & Lastr).Delete
Sheets("Main").Select
wbopen.Close
r = vbCancel
MsgBox "Please Restart the Process.", vbOKOnly, "Input Cancelled"
Else
r = 1
End If


ErrHandler:
If Err.Number = 13 Then
Output = MsgBox("The data type entered contains non numeric characters.", vbRetryCancel + vbExclamation + vbDefaultButton1, "Incorrect Input")
Select Case Output
Case vbRetry
Resume Inputbegin
Case vbCancel
r = vbCancel
MsgBox "Please Restart the Process.", vbOKOnly + vbInformation, "Input Cancelled"
Sheets("IBR").Delete
Sheets("Contract").Range("D1").ClearContents
Range("A2:B" & Lastr).Delete
Sheets("Main").Select
wbopen.Close
End Select
End If


End Function