vba 将工作表复制到 VbScript 中的新工作簿 - “调用的对象与其客户端断开连接”错误代码：80010108
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/20275545/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy Worksheet to a New WorkBook in VbScript - "the object invoked is disconnected from its clients" error code: 80010108
提问by arunpandiyarajhen
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.
我是 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
回答by Siddharth Rout
The problem is the new object now is wbDstand not objWorkbook
问题是新对象现在是wbDst而不是objWorkbook
The object objWorkbookwas already destroyed. You declared a new object wbDstin this line
该对象objWorkbook已经被销毁。您wbDst在这一行中声明了一个新对象
set wbDst = objExcel.workbooks.open(strFileName)
So simply change the line
所以只需更改行
objWorkbook.SaveAs(strFileName)
to
到
wbDst.Save
You don't need a .SaveAsagain
你不需要.SaveAs再次
Ideally, you don't need to quit and close excel. You can keep the file open and instead of using wbDst, use objWorkbook
理想情况下，您不需要退出和关闭 excel。您可以保持文件打开，而不是使用wbDst，使用objWorkbook
EDIT
编辑
Your code can be re-written as (UNTESTED).
您的代码可以重写为 (UNTESTED)。
Note: You need to close wbSrcas well else you will have lot of files open.
注意：您也需要关闭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
BTW, your code can be further fine tuned. For example, you do not require the Countervariable.
顺便说一句，您的代码可以进一步微调。例如，您不需要该Counter变量。
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
回答by jacouh
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:
当您调用 objExcel.Quit 时，没有 Excel 实例可用。所以你不能再这样做了：
set wbDst = objExcel.workbooks.open(strFileName)
As here objExcel is dead - disconnected from Excel.Application.
因为这里 objExcel 已经死了 - 与 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
