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

我是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 

Answer 1

问题是现在的新对象是wbDst而不是objWorkbook

objWorkbook对象已经被销毁了。 你在这一行中声明了一个新的对象wbDst

 set wbDst = objExcel.workbooks.open(strFileName) 

所以简单地改变这一行

 objWorkbook.SaveAs(strFileName) 

至

 wbDst.Save 

你再也不需要了

理想情况下，您不需要退出并closuresexcel。 你可以保持打开的文件，而不是使用wbDst ，使用objWorkbook

编辑

您的代码可以重写为（UNTESTED）。

注意 ：您还需要closureswbSrc ，否则您将打开大量文件。

 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 

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

最终编辑

尝试和testing

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

尝试在脚本中间注释这一行：

 'objExcel.Quit 'created an empty excel file 

当你调用objExcel.Quit时，没有Excel实例在生活中。 所以你不能在这之后做：

 set wbDst = objExcel.workbooks.open(strFileName) 

因为这里objExcel已经死了 – 与Excel.Application断开连接。

请复制并粘贴这个完整的代码进行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