无法在VbScript中复制Excel中的大量数据

我正在VbScript中将单个工作簿中文件夹中所有文件的所有工作表复制并保存。

我有4个工作簿。 每个包含1个工作表。

工作表1 = 1 MB，工作表2 = 19 MB，工作表3 = 48 MB，工作表4 = 3 MB

在工作表3以外的所有工作表中，工作表都被正确复制。

在工作表3中，只有一半的数据被复制。 它背后的问题是什么？

请find下面的代码。 感谢提前。

'~~> Change Paths as applicable Dim objExcel, objWorkbook, Temp, wbSrc Dim objShell, fol, strFileName, strDirectory, extension, Filename Dim objFSO, objFolder, objFile strFileName = "C:\Users\ARUN\Desktop\LD.xlsx" Set objExcel = CreateObject("Excel.Application") objExcel.Visible = True Set objWorkbook = objExcel.Workbooks.Add() extension = "xlsx" strDirectory = InputBox("Enter the Folder Path:","Folder Path") 'strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project" Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strDirectory) 'For loop to count the number of files starts For Each objFile In objFolder.Files if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then counter = counter + 1 'Get the file name FileName = objFile.Name 'Temp = msgbox(FileName,0,"File Name" ) end if Next 'For loop to count the number of files ends Temp = "There are " & counter & " '. " & extension & "' files in the " & strDirectory & " folder path." Set objShell = Wscript.CreateObject("Wscript.Shell") objShell.Popup Temp,2,"Files Count" 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 objWorkbook.sheets("Sheet1").Delete objWorkbook.sheets("Sheet2").Delete objWorkbook.sheets("Sheet3").Delete '~~> Close and Cleanup objWorkbook.SaveAs (strFileName) objWorkbook.Close objExcel.Quit objShell.Popup "All The Files Are Merged!!!",2,"Success" Set fol = objFSO.GetFolder(strDirectory) FolderName = InputBox("Enter the Folder Path:","Folder Path") FolderNameMove = FolderName & "\" objFSO.CopyFile strFileName, FolderNameMove 

Answer 1

就像我说的，我不确定可能是什么原因，你没有得到一个错误。 可能是内存问题？ 但是，正如我在上面的评论中所build议的那样，您可以按照本“ 链接 Way 2所述的方法复制单元格

也正如我所提到的，创build的新工作簿不一定要有3表。 这一切都取决于Excel设置。 如果您看到Excel选项，您会注意到默认设置是3

如果用户将其设置为2会怎么样？ 然后你的代码

 objWorkbook.sheets("Sheet1").Delete objWorkbook.sheets("Sheet2").Delete objWorkbook.sheets("Sheet3").Delete 

将在3rd行失败，因为没有这个名字的表。 同样在不同的区域设置下，工作表的名称可能不是Sheet1 ， Sheet2或Sheet3 。 我们可能会试图使用On Error Resume Next来删除工作表。 例如

 On Error Resume Next objWorkbook.sheets("Sheet1").Delete objWorkbook.sheets("Sheet2").Delete objWorkbook.sheets("Sheet3").Delete On Error GoTo 0 

要么

 On Error Resume Next objWorkbook.sheets(1).Delete objWorkbook.sheets(2).Delete objWorkbook.sheets(3).Delete On Error GoTo 0 

这将工作，但如果默认设置是5 ， 额外的2纸发生了什么？ 所以最好的方法是

1. 要删除除了1张表以外的所有表格，Excel将不会让您删除该表格

2. 添加新的工作表。 这里的诀窍是你添加所有的新表到最后

3. 完成后，只需删除第一张。

试试这个（ TRIED AND TESTED ）

 Dim objExcel, objWorkbook, wbSrc, wsNew 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() '~~> This will delete all sheets except the first sheet '~~> We can delete this sheet at the end. objExcel.DisplayAlerts = False On Error Resume Next For Each ws In objWorkbook.Worksheets ws.Delete Next On Error GoTo 0 objExcel.DisplayAlerts = True 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) '~~> Add the new worksheet at the end Set wsNew = objWorkbook.Sheets.Add(, objWorkbook.Sheets(objWorkbook.Sheets.Count)) wbSrc.Sheets(1).Cells.Copy wsNew.Cells wbSrc.Close End If Next '~~> Since all worksheets were added in the end, we can delete sheet(1) '~~> We still use On error resume next becuase what if no sheets were added. objExcel.DisplayAlerts = False On Error Resume Next objWorkbook.Sheets(1).Delete On Error GoTo 0 objExcel.DisplayAlerts = True '~~> Close and Cleanup objWorkbook.SaveAs (strFileName) objWorkbook.Close objExcel.Quit Set wsNew = Nothing Set wbSrc = Nothing Set objWorkbook = Nothing Set objExcel = Nothing