Unable to Copy huge volume of data in Excel in VbScript

Question

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

I have 4 workbooks. Each contains 1 worksheet.

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

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

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

Answer 1

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

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

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

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

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

or

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

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. To delete all sheets except 1 sheet as Excel will not let you delete that

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

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

Try this (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