无法在 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

就像我说的，我不确定可能是什么原因，因为您没有收到错误消息。可能是内存问题？但是，正如我在上面的 cmets 中所建议的那样，您可以按照 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