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

Question

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

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

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

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

在工作表3中，只复制了1/2的数据。它背后的问题是什么？

请找到以下代码。谢谢你的到来。

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

就像我说的那样，我不确定是什么原因，因为你没有收到错误。可能是内存问题？但是正如我在上面的评论中所建议的那样，您可以按照LINK Way 2

中提到的那样复制细胞

同样我提到的，创建的新工作簿不一定需要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. 完成后，只需删除第一张表。

尝试此操作（已完成测试）

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