Home » excel » excel – Copy Worksheet to a New WorkBook in VbScript – "the object invoked is disconnected from its clients" error code: 80010108

excel – Copy Worksheet to a New WorkBook in VbScript – "the object invoked is disconnected from its clients" error code: 80010108

Posted by: admin May 14, 2020 Leave a comment

Questions:

I’m new to VbScript. I’m trying to copy all the worksheets in a folder to a single workbook. It is getting copied but it is showing an error before saving the new workbook. error:“the object invoked is disconnected from its clients”. code: 80010108. Please help me. Here is my code.

Option Explicit  
'On Error Resume Next

Dim strFileName, strDirectory, counter, extension, Temp
Dim intMessage, FileName, wbSrc, wbDst
Dim objFSO, objFolder, objFile, objExcel, objWorkbook

'create an empty excel file starts

strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True

Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.SaveAs(strFileName)

objExcel.Quit

'created an empty excel file



'file extension to look for
extension = "xlsx"  

'directory to look in
'strDirectory = InputBox("Enter the Folder Path:","Folder Path")  
strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"
counter = 0  

'File Objects Initialization

Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strDirectory)  

counter = 0

set wbDst = objExcel.workbooks.open(strFileName)

For Each objFile In objFolder.Files  
    if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then  
        counter = counter + 1 
        'Get the file name  
        FileName = objFile.Name
        FileName = strDirectory & "\" & FileName
        msgbox(FileName)
        set wbSrc = objExcel.workbooks.open(FileName)
        wbSrc.sheets(wbSrc.Sheets(1).Name).copy wbDst.sheets(counter)
    end if
Next

objWorkbook.SaveAs(strFileName)
objExcel.Quit
How to&Answers:

The problem is the new object now is wbDst and not objWorkbook

The object objWorkbook was already destroyed. You declared a new object wbDst in this line

set wbDst = objExcel.workbooks.open(strFileName)

So simply change the line

objWorkbook.SaveAs(strFileName)

to

wbDst.Save

You don’t need a .SaveAs again

Ideally, you don’t need to quit and close excel. You can keep the file open and instead of using wbDst, use objWorkbook

EDIT

Your code can be re-written as (UNTESTED).

Note: You need to close wbSrc as well else you will have lot of files open.

Dim strFileName, strDirectory, counter, extension, Temp
Dim intMessage, FileName, wbSrc
Dim objFSO, objFolder, objFile, objExcel, objWorkbook

strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True

Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.SaveAs (strFileName)

extension = "xlsx"

strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)

counter = 0

For Each objFile In objFolder.Files
    If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
        counter = counter + 1
        FileName = objFile.Name
        FileName = strDirectory & "\" & FileName
        Set wbSrc = objExcel.Workbooks.Open(FileName)
        wbSrc.Sheets(1).Copy objWorkbook.Sheets(counter)
        wbSrc.Close
    End If
Next

'~~> Close and Cleanup   
objWorkbook.Save
objWorkbook.Close
objExcel.Quit

Set wbSrc = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing

BTW, your code can be further fine tuned. For example, you do not require the Counter variable.

FINAL EDIT

TRIED AND TESTED

'~~> Change Paths as applicable
Dim objExcel, objWorkbook, wbSrc
Dim strFileName, strDirectory, extension, Filename
Dim objFSO, objFolder, objFile

strFileName = "C:\Users\Siddharth Rout\Desktop\LD.xlsx"

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True

Set objWorkbook = objExcel.Workbooks.Add()

extension = "xlsx"

strDirectory = "C:\Users\Siddharth Rout\Desktop\Excel Merger Project"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)

For Each objFile In objFolder.Files
    If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
        Filename = objFile.Name
        Filename = strDirectory & "\" & Filename
        Set wbSrc = objExcel.Workbooks.Open(Filename)
        wbSrc.Sheets(1).Copy objWorkbook.Sheets(objWorkbook.Sheets.Count)
        wbSrc.Close
    End If
Next

'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit

Set wbSrc = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing

Answer:

Try to comment this line in the middle of your script:

'objExcel.Quit

'created an empty excel file

When you call objExcel.Quit, no Excel instance is on life. So you can no more do this after:

set wbDst = objExcel.workbooks.open(strFileName)

As here objExcel is dead – disconnected from Excel.Application.

Please copy and paste this full code for testing:

Option Explicit  
'On Error Resume Next

Dim strFileName, strDirectory, counter, extension, Temp
Dim intMessage, FileName, wbSrc, wbDst
Dim objFSO, objFolder, objFile, objExcel, objWorkbook

'create an empty excel file starts

strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True

Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.SaveAs(strFileName)

'objExcel.Quit

'created an empty excel file



'file extension to look for
extension = "xlsx"  

'directory to look in
'strDirectory = InputBox("Enter the Folder Path:","Folder Path")  
strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"
counter = 0  

'File Objects Initialization

Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strDirectory)  

counter = 0

set wbDst = objExcel.workbooks.open(strFileName)

For Each objFile In objFolder.Files  
    if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then  
        counter = counter + 1 
        'Get the file name  
        FileName = objFile.Name
        FileName = strDirectory & "\" & FileName
        msgbox(FileName)
        set wbSrc = objExcel.workbooks.open(FileName)
        wbSrc.sheets(wbSrc.Sheets(1).Name).copy wbDst.sheets(counter)
    end if
Next

objWorkbook.SaveAs(strFileName)
objExcel.Quit