Vba 将工作表复制到VbScript中的新工作簿-“；调用的对象已与其客户端断开连接；错误代码：80010108_Vba_Excel_Vbscript_Scripting

Vba 将工作表复制到VbScript中的新工作簿-“；调用的对象已与其客户端断开连接；错误代码：80010108

vba excel vbscript scripting

Vba 将工作表复制到VbScript中的新工作簿-“；调用的对象已与其客户端断开连接；错误代码：80010108,vba,excel,vbscript,scripting,Vba,Excel,Vbscript,Scripting,我不熟悉VbScript。我正在尝试将文件夹中的所有工作表复制到单个工作簿中。正在复制该工作簿，但在保存新工作簿之前显示错误。错误：“调用的对象已与其客户端断开连接”。代码：80010108。请帮帮我。这是我的密码 Option Explicit 'On Error Resume Next Dim strFileName, strDirectory, counter, extension, Temp Dim intMessage, FileName, wbSrc, wbDst Dim ob

我不熟悉VbScript。我正在尝试将文件夹中的所有工作表复制到单个工作簿中。正在复制该工作簿，但在保存新工作簿之前显示错误。错误：“调用的对象已与其客户端断开连接”。代码：80010108。请帮帮我。这是我的密码

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

试着在你的脚本中间评论这行：当您调用objExcel.Quit时，生命中没有Excel实例。因此，在以下情况下，您不能再执行此操作：

set wbDst = objExcel.workbooks.open(strFileName)

正如这里所示，objExcel已断开与Excel.Application的连接

请复制并粘贴此完整代码以进行测试：试着在你的脚本中间评论这行：当您调用objExcel.Quit时，生命中没有Excel实例。因此，在以下情况下，您不能再执行此操作：

set wbDst = objExcel.workbooks.open(strFileName)

正如这里所示，objExcel已断开与Excel.Application的连接

请复制并粘贴此完整代码以进行测试：

问题是新对象现在是

wbDst

，而不是

objWorkbook

对象

objWorkbook

已被销毁。您在此行中声明了一个新对象

wbDst

set wbDst = objExcel.workbooks.open(strFileName)

所以只要换一条线就行了

objWorkbook.SaveAs(strFileName)

到

您不再需要

.SaveAs

理想情况下，您不需要退出并关闭excel。您可以保持文件打开，而不是使用

wbDst

，而是使用

objWorkbook

编辑

您的代码可以重新编写为（未测试）

注意：您需要关闭

wbSrc

，否则将打开大量文件

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

顺便说一句，您的代码可以进一步微调。例如，您不需要

计数器

变量

最终编辑

经过尝试和测试

'~~> 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