2

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
Community
  • 1
  • 1
arunpandiyarajhen
  • 643
  • 12
  • 20
  • 51
  • Is it always the same amount of data that is copied? And do you get any errors? – Sam Nov 29 '13 at 20:41
  • worksheet 3 would be around 40 MB and worksheet 4 might vary. worksheet 1 and 2 are same. I'm not sure whether the file size is the issue in copying. – arunpandiyarajhen Nov 29 '13 at 20:43
  • 1
    I meant the row count. – Sam Nov 29 '13 at 20:43
  • Maybe it's closing before finishing the larger copy. Try throwing `DoEvents` between the copy and close lines. – usncahill Nov 29 '13 at 20:45
  • @usncahill, Could you please gimme an example? – arunpandiyarajhen Nov 29 '13 at 20:51
  • What version of excel are you using? It's not a row limit imposed by the version you're using is it? – Sam Nov 29 '13 at 21:03
  • 1
    Check your excel settings - could it be that your default workbook is still set to `.xls` format, i.e. 2003? In this case, `Workbooks.Add` might create a 2003 workbook limited to 65k rows, which might be less that your third 40MB file in 2007 format has... – Peter Albert Nov 29 '13 at 21:18
  • If what @PeterAlbert recommended doesn't work, the change would look like: `wbSrc.Sheets(1).Copy, DoEvents(), objWorkbook.Sheets(objWorkbook.Sheets.Count) wbSrc.Close` – usncahill Nov 29 '13 at 21:25
  • 2
    Every One has given some very excellent suggestions. I have a question. `In worksheet 3, only 1/2 of the data is copied.` What did you exactly mean by `Half` Did you actually mean half or is it an assumption. Also I see that you are deleting `sheet1,2,3` Please note that that code will fail if you default setting in excel for new workbook is not 3 sheets. There is a different way to get rid of those sheets. – Siddharth Rout Nov 29 '13 at 21:31
  • @SiddharthRout, I'm deleting the sheet 1,2,3 only after copying the other worksheets to the file. In worksheet 3 there were around 45k records but only 26k records are copied in the new worksheet. So, I meant it is a half of the actual volume. – arunpandiyarajhen Nov 29 '13 at 21:40
  • yes but that is the wrong way to delete. anyways, I will come to that later. Let me rethink the copy issue from different angle... – Siddharth Rout Nov 29 '13 at 21:41
  • @SiddharthRout, Thanks a lot. Let me know if you need any details. – arunpandiyarajhen Nov 29 '13 at 21:43
  • 1
    What happens if you use `WAY 2` as mentioned in this [LINK](http://stackoverflow.com/questions/19584497/how-to-replicate-a-sheet-using-vba-macro-not-copy-replicate) Are you able to copy? – Siddharth Rout Nov 29 '13 at 21:44
  • @SiddharthRout, Let me try it at once. – arunpandiyarajhen Nov 29 '13 at 21:52
  • @SiddharthRout, Success!!! :) Could you please explain what is the reason behind it? and also the way to remove the default sheets. – arunpandiyarajhen Nov 29 '13 at 22:09
  • honestly, i am not sure as to what could be the reason as you are not getting an error message. cud be a memory issue? cud be something else? anyways, let me post the code for deleting the worksheets in 15-20 mns... posting this from a mobile. – Siddharth Rout Nov 29 '13 at 22:18
  • @SiddharthRout, I've noticed one strange think. The data is exact in the worksheet 3 now but the file size is reduced. I tried to copy worksheet 3 alone. The actual size is 43 MB now (today's file) but when I copied it to the new workbook, the new workbook is very less (18 MB). The data is matching perfectly. I don't know what is the reason for the reduced size. – arunpandiyarajhen Nov 29 '13 at 22:23
  • Ok I am back gimme couple of minutes posting an answer. – Siddharth Rout Nov 29 '13 at 22:31

1 Answers1

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

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

enter image description here

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
Community
  • 1
  • 1
Siddharth Rout
  • 147,039
  • 17
  • 206
  • 250
  • why we are setting the objects to nothing at the end? I tried to Google it but I couldn't understand the reason clearly. could you explain? – arunpandiyarajhen Nov 30 '13 at 16:59
  • 2
    I just had an accident so i cant type much. too much pain in fingers... Here is one link... http://stackoverflow.com/questions/14396998/how-to-clear-memory-to-prevent-out-of-memory-error-in-excel-vba For more search google on `vba releasing objects` – Siddharth Rout Nov 30 '13 at 17:55
  • 1
    Oh God! Sorry. Take rest Sid. Hope you recover soon. Even this shows how much you love VBScript. :) – arunpandiyarajhen Nov 30 '13 at 17:58
  • @arunpandiyarajhen: Were you able to understand why we were setting the objects to nothing at the end? – Siddharth Rout Dec 11 '13 at 05:59
  • Yes Sid!! Just to release the memory allocated for the object, we are setting the objects to nothing. :) – arunpandiyarajhen Dec 14 '13 at 13:29