Unable to Copy huge volume of data in Excel in VbScript - excel

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
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.
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