无法在VBScript中复制Excel中的大量数据 [英] Unable to Copy huge volume of data in Excel in VbScript

问题描述

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

I'm working in VbScript to Copy all the worksheets of all the files in a folder in a single workbook and save it.

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

I have 4 workbooks. Each contains 1 worksheet.

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

worksheet 1 = 1 MB, worksheet 2 = 19 MB, worksheet 3 = 48 MB and worksheet 4 = 3 MB

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

The worksheets are copied properly in all the sheets except worksheet 3.

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

In worksheet 3, only 1/2 of the data is copied. What is the issue behind it?

请在下面找到代码。谢谢提前。

Please find the code below. Thanks is advance.

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

推荐答案

像我说的，我不知道什么可能是因为你没有得到错误的原因。可能是记忆问题？但是，正如我在上面的评论中所建议的，您可以按照 LINK 方式2

Like I said, I am not sure what could be the reason as you are not getting an error. Possibly a memory issue? However as I suggested in comments above, you can copy the cells across as mentioned in this LINK Way 2

也像我提到的，它是不需要创建的新工作簿将具有 3 表。这一切都取决于Excel设置。如果您看到Excel选项，您会注意到默认设置为 3

Also like I mentioned, it is not necessary that the the new workbook that is created will have 3 sheets. It all depends on the Excel settings. If you see Excel Options, you will notice that the default setting is 3

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

What if a user has set it to 2? Then your code

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

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

will fail on the 3rd line as there is no sheet by that name. Also under different, regional settings, the names of the sheet might not be Sheet1, Sheet2 or Sheet3. We might be tempted to use On Error Resume Next to delete the sheets. For example

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 表格会发生什么。所以最好的办法就是

This will work but then what if the default setting is 5. What happens to the additional 2 sheets. So the best approach is

1. 删除1张以外的所有表，Excel不会让你删除

1. To delete all sheets except 1 sheet as Excel will not let you delete that

添加新的工作表。这里的诀窍是，您将所有新的表格添加到最后

Add new sheets. The trick here is that you add all the new sheets to the end

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

Once you are done, simply delete the 1st sheet.

尝试这个（ 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

这篇关于无法在VBScript中复制Excel中的大量数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！